idhl7.pas

Indy控件的使用源代码

{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence                                   }
{ Team Coherence is Copyright 2002 by Quality Software Components      }
{                                                                      }
{ For further information / comments, visit our WEB site at            }
{ http://www.TeamCoherence.com                                         }
{**********************************************************************}
{}
{ $Log:  10187: IdHL7.pas 
{
{   Rev 1.2    20/6/2003 11:16:36  GGrieve
{ fix compile problem
}
{
{   Rev 1.1    20/6/2003 08:59:28  GGrieve
{ connection in events, and fix problem with singleThread mode
}
{
  Indy HL7 Minimal Lower Layer Protocol TIdHL7

    Original author Grahame Grieve

    This code was donated by HL7Connect.com
    For more HL7 open source code see
    http://www.hl7connect.com/tools

  This unit implements support for the Standard HL7 minimal Lower Layer
  protocol. For further details, consult the HL7 standard (www.hl7.org).

  Before you can use this component, you must set the following properties:
    CommunicationMode
    Address (if you want to be a client)
    Port
    isListener
  and hook the appropriate events (see below)

  This component will operate as either a server or a client depending on
  the configuration
}

{
 Version History:
   20/06/2003   Grahame Grieve      Add Connection to events. (break existing code, sorry)
   05/09/2002   Grahame Grieve      Fixed SingleThread Timeout Issues + WaitForConnection
   23/01/2002   Grahame Grieve      Fixed for network changes to TIdTCPxxx
                                    wrote DUnit testing,
                                    increased assertions
                                    change OnMessageReceive - added VHandled parameter
   07/12/2001   Grahame Grieve      Various fixes for cmSingleThread mode
   05/11/2001   Grahame Grieve      Merge into Indy
   03/09/2001   Grahame Grieve      Prepare for Indy
}

(* note: Events are structurally important for this component. However there is
  a bug in SyncObjs for Linux under Kylix 1 and 2 where TEvent.WaitFor cannot be
  used with timeouts. If you compile your own RTL, then you can fix the routine
  like this:

    function TEvent.WaitFor(Timeout: LongWord): TWaitResult;
    {$IFDEF LINUX}
    var ts : TTimeSpec;
    begin
      ts.tv_sec  := timeout div 1000;
      ts.tv_nsec := (timeout mod 1000) * 1000000;
      if sem_timedwait(FSem, ts) = 0 then
        result := wrSignaled
      else
        result := wrTimeOut;
    {$ENDIF}

  and then disable this define: *)

  { this is a serious issue - unless you fix the RTL, this component does not
    function properly on Linux at the present time. This may be fixed in a
    future version }

unit IdHL7;

interface

uses
  Classes,
  IdBaseComponent,
  IdException,
  IdGlobal,
  IdTCPClient,
  IdTCPConnection,
  IdTCPServer,
  SyncObjs,
  SysUtils;

const
  MSG_START = #$0B;       {do not localize}
  MSG_END = #$1C#$0D;   {do not localize}

  BUFFER_SIZE_LIMIT = 1024 * 1024;  // buffer is allowed to grow to this size without any
  // valid messages. Will be truncated with no notice (DoS protection)

  WAIT_STOP = 5000; // nhow long we wait for things to shut down cleanly

type
  EHL7CommunicationError = class(EIdException)
  Protected
    FInterfaceName: String;
  Public
    constructor Create(AnInterfaceName, AMessage: String);
    property InterfaceName: String Read FInterfaceName;
  end;


  THL7CommunicationMode = (cmUnknown,        // not valid - default setting must be changed by application
    cmAsynchronous,   // see comments below for meanings of the other parameters
    cmSynchronous,
    cmSingleThread);

  TSendResponse = (srNone,          // internal use only - never returned
    srError,         // internal use only - never returned
    srNoConnection,  // you tried to send but there was no connection
    srSent,          // you asked to send without waiting, and it has been done
    srOK,            // sent ok, and response returned
    srTimeout);      // we sent but there was no response (connection will be dropped internally

  TIdHL7Status = (isStopped,       // not doing anything
    isNotConnected,  // not Connected (Server state)
    isConnecting,    // Client is attempting to connect
    isWaitReconnect, // Client is in delay loop prior to attempting to connect
    isConnected,     // connected OK
    isUnusable       // Not Usable - stop failed
    );

const
  { default property values }
  DEFAULT_ADDRESS = '';         {do not localize}
  DEFAULT_PORT = 0;
  DEFAULT_TIMEOUT = 30000;
  DEFAULT_RECEIVE_TIMEOUT = 30000;
  NULL_IP = '0.0.0.0';  {do not localize}
  DEFAULT_CONN_LIMIT = 1;
  DEFAULT_RECONNECT_DELAY = 15000;
  DEFAULT_COMM_MODE = cmUnknown;
  DEFAULT_IS_LISTENER = True;
  MILLISECOND_LENGTH = (1 / (24 * 60 * 60 * 1000));

type
  // the connection is provided in these events so that applications can obtain information about the
  // the peer. It's never OK to write to these connections
  TMessageArriveEvent = procedure(ASender: TObject; AConnection: TIdTCPConnection; AMsg: String) of object;
  TMessageReceiveEvent = procedure(ASender: TObject; AConnection: TIdTCPConnection; AMsg: String; var VHandled: Boolean; var VReply: String) of object;
  TReceiveErrorEvent = procedure(ASender: TObject; AConnection: TIdTCPConnection; AMsg: String; AException: Exception; var VReply: String; var VDropConnection: Boolean) of object;

  TIdHL7 = class;
  TIdHL7ConnCountEvent = procedure(ASender: TIdHL7; AConnCount: Integer) of object;

  TIdHL7PeerThread = class(TIdPeerThread)
  Protected
    FBuffer: String;
  Public
    constructor Create(ACreateSuspended: Boolean = True); Override;
    destructor Destroy; Override;
  end;

  TIdHL7ClientThread = class(TThread)
  Protected
    FClient: TIdTCPClient;
    FCloseEvent: TIdLocalEvent;
    FOwner: TIdHL7;
    procedure Execute; Override;
    procedure PollStack;
  Public
    constructor Create(aOwner: TIdHL7);
    destructor Destroy; Override;
  end;

  TIdHL7 = class(TIdBaseComponent)
  Protected
    FLock: TCriticalSection;
    FStatus: TIdHL7Status;
    FStatusDesc: String;

    // these queues hold messages when running in singlethread mode
    FMsgQueue: TList;
    FHndMsgQueue: TList;

    FAddress: String;
    FCommunicationMode: THL7CommunicationMode;
    FConnectionLimit: Word;
    FIPMask: String;
    FIPRestriction: String;
    FIsListener: Boolean;
    FObject: TObject;
    FPreStopped: Boolean;
    FPort: Word;
    FReconnectDelay: Cardinal;
    FTimeOut: Cardinal;
    FReceiveTimeout: Cardinal;


    FOnConnect: TNotifyEvent;
    FOnDisconnect: TNotifyEvent;
    FOnConnCountChange: TIdHL7ConnCountEvent;
    FOnMessageArrive: TMessageArriveEvent;
    FOnReceiveMessage: TMessageReceiveEvent;
    FOnReceiveError: TReceiveErrorEvent;

    FIsServer: Boolean;
    // current connection count (server only) (can only exceed 1 when mode is not
    // asynchronous and we are listening)
    FConnCount: Integer;
    FServer: TIdTCPServer;
    // if we are a server, and the mode is not asynchronous, and we are not listening, then
    // we will track the current server connection with this, so we can initiate sending on it
    FServerConn: TIdTCPServerConnection;

    // A thread exists to connect and receive incoming tcp traffic
    FClientThread: TIdHL7ClientThread;
    FClient: TIdTCPClient;

    // these fields are used for handling message response in synchronous mode
    FWaitingForAnswer: Boolean;
    FWaitStop: TDatetime;
    FMsgReply: String;
    FReplyResponse: TSendResponse;
    FWaitEvent: TIdLocalEvent;

    procedure SetAddress(const AValue: String);
    procedure SetConnectionLimit(const AValue: Word);
    procedure SetIPMask(const AValue: String);
    procedure SetIPRestriction(const AValue: String);
    procedure SetPort(const AValue: Word);
    procedure SetReconnectDelay(const AValue: Cardinal);
    procedure SetTimeOut(const AValue: Cardinal);
    procedure SetCommunicationMode(const AValue: THL7CommunicationMode);
    procedure SetIsListener(const AValue: Boolean);
    function GetStatus: TIdHL7Status;
    function GetStatusDesc: String;

    procedure InternalSetStatus(const AStatus: TIdHL7Status; ADesc: String);

    procedure CheckServerParameters;
    procedure StartServer;
    procedure StopServer;
    procedure DropServerConnection;
    procedure ServerConnect(AThread: TIdPeerThread);
    procedure ServerExecute(AThread: TIdPeerThread);
    procedure ServerDisconnect(AThread: TIdPeerThread);

    procedure CheckClientParameters;
    procedure StartClient;
    procedure StopClient;
    procedure DropClientConnection;

    procedure HandleIncoming(var VBuffer: String; AConnection: TIdTCPConnection);
    function HandleMessage(const AMsg: String; AConn: TIdTCPConnection; var VReply: String): Boolean;
  Public
    constructor Create(Component: TComponent); Override;
    destructor Destroy; Override;

    procedure EnforceWaitReplyTimeout;

    function Going: Boolean;

    // for the app to use to hold any related object
    property ObjTag: TObject Read FObject Write FObject;

    // status
    property Status: TIdHL7Status Read GetStatus;
    property StatusDesc: String Read GetStatusDesc;
    function Connected: Boolean;

    property IsServer: Boolean Read FIsServer;
    procedure Start;
    procedure PreStop; // call this in advance to start the shut down process. You do not need to call this
    procedure Stop;

    procedure WaitForConnection(AMaxLength: Integer); // milliseconds

    // asynchronous.
    function AsynchronousSend(AMsg: String): TSendResponse;
    property OnMessageArrive: TMessageArriveEvent Read FOnMessageArrive Write FOnMessageArrive;

    // synchronous
    function SynchronousSend(AMsg: String; var VReply: String): TSendResponse;
    property OnReceiveMessage: TMessageReceiveEvent Read FOnReceiveMessage Write FOnReceiveMessage;
    procedure CheckSynchronousSendResult(AResult: TSendResponse; AMsg: String);

    // single thread
    procedure SendMessage(AMsg: String);
    // you can't call SendMessage again without calling GetReply first
    function GetReply(var VReply: String): TSendResponse;
    function GetMessage(var VMsg: String): pointer;  // return nil if no messages
    // if you don't call SendReply then no reply will be sent.
    procedure SendReply(AMsgHnd: pointer; AReply: String);

  Published
    // basic properties
    property Address: String Read FAddress Write SetAddress;  // leave blank and we will be server
    property Port: Word Read FPort Write SetPort Default DEFAULT_PORT;

    // milliseconds - message timeout - how long we wait for other system to reply
    property TimeOut: Cardinal Read FTimeOut Write SetTimeOut Default DEFAULT_TIMEOUT;

    // milliseconds - message timeout. When running cmSingleThread, how long we wait for the application to process an incoming message before giving up
    property ReceiveTimeout: Cardinal Read FReceiveTimeout Write FReceiveTimeout Default DEFAULT_RECEIVE_TIMEOUT;

    // server properties
    property ConnectionLimit: Word Read FConnectionLimit Write SetConnectionLimit Default DEFAULT_CONN_LIMIT; // ignored if isListener is false
    property IPRestriction: String Read FIPRestriction Write SetIPRestriction;
    property IPMask: String Read FIPMask Write SetIPMask;

    // client properties

    // milliseconds - how long we wait after losing connection to retry
    property ReconnectDelay: Cardinal Read FReconnectDelay Write SetReconnectDelay Default DEFAULT_RECONNECT_DELAY;

    // message flow

    // Set this to one of 4 possibilities:
    //
    //    cmUnknown
    //       Default at start up. You must set a value before starting
    //
    //    cmAsynchronous
    //        Send Messages with AsynchronousSend. does not wait for
    //                   remote side to respond before returning
    //        Receive Messages with OnMessageArrive. Message may
    //                   be response or new message
    //       The application is responsible for responding to the remote
    //       application and dropping the link as required
    //       You must hook the OnMessageArrive Event before setting this mode
    //       The property IsListener has no meaning in this mode
    //
    //   cmSynchronous
    //       Send Messages with SynchronousSend. Remote applications response
    //                   will be returned (or timeout). Only use if IsListener is false
    //       Receive Messages with OnReceiveMessage. Only if IsListener is
    //                   true
    //       In this mode, the object will wait for a response when sending,
    //       and expects the application to reply when a message arrives.
    //       In this mode, the interface can either be the listener or the
    //       initiator but not both. IsListener controls which one.
    //       note that OnReceiveMessage must be thread safe if you allow
    //       more than one connection to a server
    //
    //   cmSingleThread
    //       Send Messages with SendMessage. Poll for answer using GetReply.
    //                   Only if isListener is false
    //       Receive Messages using GetMessage. Return a response using
    //                   SendReply. Only if IsListener is true
    //       This mode is the same as cmSynchronous, but the application is
    //       assumed to be single threaded. The application must poll to
    //       find out what is happening rather than being informed using
    //       an event in a different thread

    property CommunicationMode: THL7CommunicationMode Read FCommunicationMode Write SetCommunicationMode Default DEFAULT_COMM_MODE;

    // note that IsListener is not related to which end is client. Either end
    // may make the connection, and thereafter only one end will be the initiator
    // and one end will be the listener. Generally it is recommended that the
    // listener be the server. If the client is listening, network conditions
    // may lead to a state where the client has a phantom connection and it will
    // never find out since it doesn't initiate traffic. In this case, restart
    // the interface if there isn't traffic for a period
    property IsListener: Boolean Read FIsListener Write SetIsListener Default DEFAULT_IS_LISTENER;

    // useful for application
    property OnConnect: TNotifyEvent Read FOnConnect Write FOnConnect;
    property OnDisconnect: TNotifyEvent Read FOnDisconnect Write FOnDisconnect;
    // this is called whenever OnConnect and OnDisconnect are called, and at other times, but only when server
    // it will be called after OnConnect and before OnDisconnect
    property OnConnCountChange: TIdHL7ConnCountEvent Read FOnConnCountChange Write FOnConnCountChange;

    // this is called when an unhandled exception is generated by the
    // hl7 object or the application. It allows the application to
    // construct a useful return error, log the exception, and drop the
    // connection if it wants
    property OnReceiveError: TReceiveErrorEvent Read FOnReceiveError Write FOnReceiveError;
  end;

resourcestring
  KdeVersionMark = {!!uv}'!-!IdHL7.pas,0.00-019,21 May 03 09:09,12259';

implementation

uses
  IdResourceStrings;

type
  TQueuedMessage = class(TInterfacedObject)
  Private
    FEvent: TIdLocalEvent;
    FMsg: String;
    FTimeOut: Cardinal;
    FReply: String;
    procedure Wait;
  Public
    constructor Create(aMsg: String; ATimeOut: Cardinal);
    destructor Destroy; Override;
    function _AddRef: Integer; Stdcall;
    function _Release: Integer; Stdcall;
  end;