idhl7.pas

Indy控件的使用源代码

  { TQueuedMessage }

constructor TQueuedMessage.Create(aMsg: String; ATimeOut: Cardinal);
begin
  assert(aMsg <> '', 'Attempt to queue an empty message');
  assert(ATimeout <> 0, 'Attempt to queue a message with a 0 timeout');
  inherited Create;
  FEvent := TIdLocalEvent.Create(False, False);
  FMsg := aMsg;
  FTimeOut := ATimeOut;
end;

destructor TQueuedMessage.Destroy;
begin
  assert(self <> NIL);
  FreeAndNil(FEvent);
  inherited;
end;

procedure TQueuedMessage.Wait;
begin
  assert(self <> NIL);
  assert(assigned(FEvent));
  FEvent.WaitFor(FTimeOut);
end;

function TQueuedMessage._AddRef: Integer;
begin
  Result := inherited _AddRef;
end;

function TQueuedMessage._Release: Integer;
begin
  Result := inherited _Release;
end;

{ EHL7CommunicationError }

constructor EHL7CommunicationError.Create(AnInterfaceName, AMessage: String);
begin
  //  assert(AInterfaceName <> '', 'Attempt to create an exception for an unnamed interface')
  //  assert(AMessage <> '', 'Attempt to create an exception with an empty message')
  //  actually, we do not enforce either of these conditions, though they should both be true,
  //  since we are already raising an exception
  FInterfaceName := AnInterfaceName;
  if FInterfaceName <> '' then         {do not localize}
    begin
    inherited Create('[' + AnInterfaceName + '] ' + AMessage)
    end
  else
    begin
    inherited Create(AMessage);
    end
end;

{ TIdHL7 }

constructor TIdHL7.Create;
begin
  inherited Create(Component);

  // partly redundant initialization of properties

  FIsListener := DEFAULT_IS_LISTENER;
  FCommunicationMode := DEFAULT_COMM_MODE;
  FTimeOut := DEFAULT_TIMEOUT;
  FReconnectDelay := DEFAULT_RECONNECT_DELAY;
  FReceiveTimeout := DEFAULT_RECEIVE_TIMEOUT;
  FConnectionLimit := DEFAULT_CONN_LIMIT;
  FIPMask := NULL_IP;
  FIPRestriction := NULL_IP;
  FAddress := DEFAULT_ADDRESS;
  FPort := DEFAULT_PORT;
  FOnReceiveMessage := NIL;
  FOnConnect := NIL;
  FOnDisconnect := NIL;
  FObject := NIL;

  // initialise status
  FStatus := IsStopped;
  FStatusDesc := RSHL7StatusStopped;

  // build internal infrastructure
  Flock := TCriticalSection.Create;
  FConnCount := 0;
  FServer := NIL;
  FServerConn := NIL;
  FClientThread := NIL;
  FClient := NIL;
  FMsgQueue := TList.Create;
  FHndMsgQueue := TList.Create;
  FWaitingForAnswer := False;
  FMsgReply := '';   {do not localize}
  FReplyResponse := srNone;
  FWaitEvent := TIdLocalEvent.Create(False, False);
end;

destructor TIdHL7.Destroy;
begin
  assert(assigned(self));
  try
    if Going then
      begin
      Stop;
      end;
  finally
    FreeAndNil(FMsgQueue);
    FreeAndNil(FHndMsgQueue);
    FreeAndNil(FWaitEvent);
    FreeAndNil(FLock);
    inherited;
    end;
end;

{==========================================================
  Property Servers
 ==========================================================}

procedure TIdHL7.SetAddress(const AValue: String);
begin
  assert(assigned(self));
  // we don't make any assertions about AValue - will be '' if we are a server
  if Going then
    begin
    raise EHL7CommunicationError.Create(Name, Format(RSHL7NotWhileWorking, ['Address']));   {do not localize??}
    end;
  FAddress := AValue;
end;

procedure TIdHL7.SetConnectionLimit(const AValue: Word);
begin
  assert(assigned(self));
  // no restrictions on AValue
  if Going then
    begin
    raise EHL7CommunicationError.Create(Name, Format(RSHL7NotWhileWorking, ['ConnectionLimit'])); {do not localize??}
    end;
  FConnectionLimit := AValue;
end;

procedure TIdHL7.SetIPMask(const AValue: String);
begin
  assert(assigned(self));
  // to do: enforce that AValue is a valid Subnet mask
  if Going then
    begin
    raise EHL7CommunicationError.Create(Name, Format(RSHL7NotWhileWorking, ['IP Mask']));  {do not localize??}
    end;
  FIPMask := AValue;
end;

procedure TIdHL7.SetIPRestriction(const AValue: String);
begin
  assert(assigned(self));
  // to do: enforce that AValue is a valid IP address range
  if Going then
    begin
    raise EHL7CommunicationError.Create(Name, Format(RSHL7NotWhileWorking, ['IP Restriction']));    {do not localize??}
    end;
  FIPRestriction := AValue;
end;

procedure TIdHL7.SetPort(const AValue: Word);
begin
  assert(assigned(self));
  assert(AValue <> 0, 'Attempt to use Port 0 for HL7 Communications');
  if Going then
    begin
    raise EHL7CommunicationError.Create(Name, Format(RSHL7NotWhileWorking, ['Port']));          {do not localize??}
    end;
  FPort := AValue;
end;

procedure TIdHL7.SetReconnectDelay(const AValue: Cardinal);
begin
  assert(assigned(self));
  // any value for AValue is accepted, although this may not make sense
  if Going then
    begin
    raise EHL7CommunicationError.Create(Name, Format(RSHL7NotWhileWorking, ['Reconnect Delay']));   {do not localize??}
    end;
  FReconnectDelay := AValue;
end;

procedure TIdHL7.SetTimeOut(const AValue: Cardinal);
begin
  assert(assigned(self));
  assert(FTimeout > 0, 'Attempt to configure TIdHL7 with a Timeout of 0');
  // we don't fucntion at all if timeout is 0, though there is circumstances where it's not relevent
  if Going then
    begin
    raise EHL7CommunicationError.Create(Name, Format(RSHL7NotWhileWorking, ['Time Out']));          {do not localize??}
    end;
  FTimeOut := AValue;
end;

procedure TIdHL7.SetCommunicationMode(const AValue: THL7CommunicationMode);
begin
  assert(assigned(self));
  Assert((AValue >= Low(THL7CommunicationMode)) and (AValue <= High(THL7CommunicationMode)), 'Value for TIdHL7.CommunicationMode not in range');
  // only could arise if someone is typecasting?
  if Going then
    begin
    raise EHL7CommunicationError.Create(Name, Format(RSHL7NotWhileWorking, ['Communication Mode'])); {do not localize??}
    end;
  FCommunicationMode := AValue;
end;

procedure TIdHL7.SetIsListener(const AValue: Boolean);
begin
  assert(assigned(self));
  // AValue isn't checked
  if Going then
    begin
    raise EHL7CommunicationError.Create(Name, Format(RSHL7NotWhileWorking, ['IsListener']));         {do not localize??}
    end;
  FIsListener := AValue;
end;

function TIdHL7.GetStatus: TIdHL7Status;
begin
  assert(assigned(self));
  assert(Assigned(FLock));
  FLock.Enter;
  try
    Result := FStatus;
  finally
    FLock.Leave;
    end;
end;

function TIdHL7.Connected: Boolean;
begin
  assert(assigned(self));
  assert(Assigned(FLock));
  FLock.Enter;
  try
    Result := FStatus = IsConnected;
  finally
    FLock.Leave;
    end;
end;

function TIdHL7.GetStatusDesc: String;
begin
  assert(assigned(self));
  assert(Assigned(FLock));
  FLock.Enter;
  try
    Result := FStatusDesc;
  finally
    FLock.Leave;
    end;
end;

procedure TIdHL7.InternalSetStatus(const AStatus: TIdHL7Status; ADesc: String);
begin
  assert(assigned(self));
  Assert((AStatus >= Low(TIdHL7Status)) and (AStatus <= High(TIdHL7Status)), 'Value for TIdHL7.CommunicationMode not in range');
  // ADesc is allowed to be anything at all
  assert(Assigned(FLock));
  FLock.Enter;
  try
    FStatus := AStatus;
    FStatusDesc := ADesc;
  finally
    FLock.Leave;
    end;
end;

{==========================================================
  Application Control
 ==========================================================}

procedure TIdHL7.Start;
var 
  LStatus: TIdHL7Status;
begin
  assert(assigned(self));
  LStatus := GetStatus;
  if LStatus = IsUnusable then
    begin
    raise EHL7CommunicationError.Create(Name, RSHL7NotFailedToStop);
    end;
  if LStatus <> IsStopped then
    begin
    raise EHL7CommunicationError.Create(Name, RSHL7AlreadyStarted);
    end;
  if FCommunicationMode = cmUnknown then
    begin
    raise EHL7CommunicationError.Create(Name, RSHL7ModeNotSet);
    end;
  if FCommunicationMode = cmAsynchronous then
    begin
    if not assigned(FOnMessageArrive) then
      begin
      raise EHL7CommunicationError.Create(Name, RSHL7NoAsynEvent);
      end;
    end;
  if (FCommunicationMode = cmSynchronous) and IsListener then
    begin
    if not assigned(FOnReceiveMessage) then
      begin
      raise EHL7CommunicationError.Create(Name, RSHL7NoSynEvent);
      end;
    end;
  FIsServer := (FAddress = '');
  if FIsServer then
    begin
    StartServer
    end
  else
    begin
    StartClient;
    end;
  FPreStopped := False;
  FWaitingForAnswer := False;
end;

procedure TIdHL7.PreStop;
  procedure JoltList(l: TList);
  var 
    i: Integer;
    begin
    for i := 0 to l.Count - 1 do
      begin
      TQueuedMessage(l[i]).FEvent.SetEvent;
      end;
    end;
begin
  assert(assigned(self));
  if FCommunicationMode = cmSingleThread then
    begin
    assert(Assigned(FLock));
    assert(Assigned(FMsgQueue));
    assert(Assigned(FHndMsgQueue));
    FLock.Enter;
    try
      JoltList(FMsgQueue);
      JoltList(FHndMsgQueue);
    finally
      FLock.Leave;
      end;
    end;
  FPreStopped := True;
end;

procedure TIdHL7.Stop;
begin
  assert(assigned(self));
  if not Going then
    begin
    raise EHL7CommunicationError.Create(Name, RSHL7AlreadyStopped);
    end;

  if not FPreStopped then
    begin
    PreStop;
    sleep(10); // give other threads a chance to clean up
    end;

  if FIsServer then
    begin
    StopServer
    end
  else
    begin
    StopClient;
    end;
end;


{==========================================================
  Server Connection Maintainance
 ==========================================================}

procedure TIdHL7.EnforceWaitReplyTimeout;
begin
  Stop;
  Start;
end;

function TIdHL7.Going: Boolean;
var
  LStatus: TIdHL7Status;
begin
  assert(assigned(self));
  LStatus := GetStatus;
  Result := (LStatus <> IsStopped) and (LStatus <> IsUnusable);
end;

procedure TIdHL7.WaitForConnection(AMaxLength: Integer);
var
  LStopWaiting: TDateTime;
begin
  LStopWaiting := Now + (AMaxLength * ((1 / (24 * 60)) / (60 * 1000)));
  while not Connected and (LStopWaiting > now) do
    sleep(50);  
end;

procedure TIdHL7.CheckSynchronousSendResult(AResult: TSendResponse; AMsg: String);
begin