idhl7.pas

photo.163.com 相册下载器 多线程下载

              LRecTime := Now + ((FOwner.FReconnectDelay / 1000) * {second length} (1 / (24 * 60 * 60)));
              FOwner.InternalSetStatus(IsWaitReconnect, Format(rsHL7StatusReConnect, [FormatDateTime('hh:nn:ss', LRecTime), e.message])); {do not localize??}
              end;
            end;
          if not Terminated and not FClient.Connected then
            begin
            FCloseEvent.WaitFor(FOwner.FReconnectDelay);
            end;
        until Terminated or FClient.Connected;
        if Terminated then
          begin
          exit;
          end;

        FOwner.FLock.Enter;
        try
          FOwner.FClient := FClient;
          FOwner.InternalSetStatus(IsConnected, rsHL7StatusConnected);
        finally
          FOwner.FLock.Leave;
          end;
        if assigned(FOwner.FOnConnect) then
          begin
          FOwner.FOnConnect(FOwner);
          end;
        try
          PollStack;
        finally
          FOwner.FLock.Enter;
          try
            FOwner.FClient := NIL;
            FOwner.InternalSetStatus(IsNotConnected, RSHL7StatusNotConnected);
          finally
            FOwner.FLock.Leave;
            end;
          if assigned(FOwner.FOnDisconnect) then
            begin
            FOwner.FOnDisconnect(FOwner);
            end;
          end;
        if not Terminated then
          begin
          // we got disconnected. ReconnectDelay applies.
          FCloseEvent.WaitFor(FOwner.FReconnectDelay);
          end;
      until terminated;
    finally
      FreeAndNil(FClient);
      end;
  except
    on e:
    Exception do
      // presumably some comms or indy related exception
      // there's not really anyplace good to put this????
    end;
end;

{==========================================================
  Internal process management
 ==========================================================}

procedure TIdHL7.HandleIncoming(const AMsg : String; AConnection: TIdTCPConnection);
var
  LReply: String;
begin
  assert(assigned(self));
  assert(AMsg <> '', 'Attempt to handle an empty Message'); {do not localize}
  assert(assigned(AConnection));
  try
    // process any messages in the buffer (may get more than one per packet)
    if HandleMessage(AMsg, AConnection, LReply) then
      begin
      if LReply <> '' then
        begin
        AConnection.IOHandler.Write(MSG_START + LReply + MSG_END);
        end;
      end
    else
      begin
      AConnection.Disconnect;
      end;
  except
    // well, we need to suppress the exception, and force a reconnection
    // we don't know why an exception has been allowed to propagate back
    // to us, it shouldn't be allowed. so what we're going to do, is drop
    // the connection so that we force all the network layers on both
    // ends to reconnect.
    // this is a waste of time if the error came from the application but
    // this is not supposed to happen
    try
      AConnection.Disconnect;
    except
      // nothing - suppress
    end;
  end;
end;

function TIdHL7.HandleMessage(const AMsg: String; AConn: TIdTCPConnection; var VReply: String): Boolean;
var
  LQueMsg: TQueuedMessage;
  LIndex: Integer;
begin
  assert(assigned(self));
  assert(AMsg <> '', 'Attempt to handle an empty Message'); {do not localize}
  assert(assigned(FLock));
  VReply := '';
  Result := True;
  try
    case FCommunicationMode of
      cmUnknown:
        begin
        raise EHL7CommunicationError.Create(Name, RSHL7ImpossibleMessage);
        end;
      cmAsynchronous:
        begin
        FOnMessageArrive(self, AConn, Amsg);
        end;
      cmSynchronous, cmSingleThread:
        begin
        if IsListener then
          begin
          if FCommunicationMode = cmSynchronous then
            begin
            Result := False;
            FOnReceiveMessage(self, AConn, AMsg, Result, VReply)
            end
          else
            begin
            LQueMsg := TQueuedMessage.Create(AMsg, FReceiveTimeout);
            LQueMsg._AddRef;
            try
              FLock.Enter;
              try
                FMsgQueue.Add(LQueMsg);
              finally
                FLock.Leave;
                end;
              LQueMsg.wait;
              // no locking. There is potential problems here. To be reviewed
              VReply := LQueMsg.FReply;
            finally
              FLock.Enter;
              try
                LIndex := FMsgQueue.IndexOf(LQueMsg);
                if LIndex > -1 then
                  FMsgQueue.Delete(LIndex);
              finally
                FLock.Leave;
                end;
              LQueMsg._Release;
              end;
            end
          end
        else
          begin
          FLock.Enter;
          try
            if FWaitingForAnswer then
              begin
              FWaitingForAnswer := False;
              FMsgReply := AMsg;
              FReplyResponse := srOK;
              if FCommunicationMode = cmSynchronous then
                begin
                assert(Assigned(FWaitEvent));
                FWaitEvent.SetEvent;
                end;
              end
            else
              begin
              // we could have got here by timing out, but this is quite unlikely,
              // since the connection will be dropped in that case. We will report
              // this as a spurious message
              raise EHL7CommunicationError.Create(Name, RSHL7UnexpectedMessage);
              end;
          finally
            FLock.Leave;
            end;
          end
        end;
      else
        begin
        raise EHL7CommunicationError.Create(Name, RSHL7UnknownMode);
        end;
      end;
  except
    on e:
    Exception do
      if Assigned(FOnReceiveError) then
        begin
        FOnReceiveError(self, AConn, AMsg, e, VReply, Result)
        end
    else
      begin
      Result := False;
      end;
    end;
end;

{==========================================================
  Sending
 ==========================================================}

// this procedure is not technically thread safe.
// if the connection is disappearing when we are attempting
// to write, we can get transient access violations. Several
// strategies are available to prevent this but they significantly
// increase the scope of the locks, which costs more than it gains

function TIdHL7.AsynchronousSend(AMsg: String): TSendResponse;
begin
  assert(Assigned(self));
  assert(AMsg <> '', 'Attempt to send an empty message'); {do not localize}
  assert(assigned(FLock));
  Result := srNone; // just to suppress the compiler warning
  FLock.Enter;
  try
    if not Going then
      begin
      raise EHL7CommunicationError.Create(Name, Format(RSHL7NotWorking, [RSHL7SendMessage]))
      end
    else if GetStatus <> isConnected then
      begin
      Result := srNoConnection
      end
    else
      begin
      if FIsServer then
        begin
        if Assigned(FServerConn) then
          begin
          FServerConn.IOHandler.Write(MSG_START + AMsg + MSG_END);
          Result := srSent
          end
        else
          begin
          raise EHL7CommunicationError.Create(Name, RSHL7NoConnectionFound);
          end
        end
      else
        begin
        FClient.IOHandler.Write(MSG_START + AMsg + MSG_END);
        Result := srSent
        end;
      end;
  finally
    FLock.Leave;
    end
end;

function TIdHL7.SynchronousSend(AMsg: String; var VReply: String): TSendResponse;
begin
  assert(Assigned(self));
  assert(AMsg <> '', 'Attempt to send an empty message'); {do not localize}
  assert(assigned(FLock));
  Result := srError;
  FLock.Enter;
  try
    FWaitingForAnswer := True;
    FWaitStop := now + (FTimeOut * MILLISECOND_LENGTH);
    FReplyResponse := srTimeout;
    FMsgReply := '';
  finally
    FLock.Leave;
    end;
  try
    Result := AsynchronousSend(AMsg);
    if Result = srSent then
      begin
      assert(Assigned(FWaitEvent));
      FWaitEvent.WaitFor(FTimeOut);
      end;
  finally
    FLock.Enter;
    try
      FWaitingForAnswer := False;
      if Result = srSent then
        begin
        Result := FReplyResponse;
        end;
      if Result = srTimeout then
        begin
        if FIsServer then
          DropServerConnection
        else
          DropClientConnection;
        end;
      VReply := FMsgReply;
    finally
      FLock.Leave;
      end;
    end;
end;

procedure TIdHL7.SendMessage(AMsg: String);
begin
  assert(Assigned(self));
  assert(AMsg <> '', 'Attempt to send an empty message'); {do not localize}
  assert(assigned(FLock));
  if FWaitingForAnswer then
    raise EHL7CommunicationError.Create(Name, RSHL7WaitForAnswer);

  FLock.Enter;
  try
    FWaitingForAnswer := True;
    FWaitStop := now + (FTimeOut * MILLISECOND_LENGTH);
    FMsgReply := '';
    FReplyResponse := AsynchronousSend(AMsg);
  finally
    FLock.Leave;
    end;
end;

function TIdHL7.GetReply(var VReply: String): TSendResponse;
begin
  assert(Assigned(self));
  assert(assigned(FLock));
  FLock.Enter;
  try
    if FWaitingForAnswer then
      begin
      if FWaitStop < now then
        begin
        Result := srTimeout;
        VReply := '';
        FWaitingForAnswer := False;
        FReplyResponse := srError;
        end
      else
        begin
        Result := srNone;
        end;
      end
    else
      begin
      Result := FReplyResponse;
      if Result = srSent then
        begin
        Result := srTimeOut;
        end;
      VReply := FMsgReply;
      FWaitingForAnswer := False;
      FReplyResponse := srError;
      end;
  finally
    FLock.Leave;
    end;
end;

function TIdHL7.GetMessage(var VMsg: String): TObject;
begin
  assert(Assigned(self));
  assert(assigned(FLock));
  assert(assigned(FMsgQueue));
  FLock.Enter;
  try
    if FMsgQueue.Count = 0 then
      begin
      Result := NIL;
      end
    else
      begin
      Result := FMsgQueue[0];
      TQueuedMessage(Result)._AddRef;
      VMsg := TQueuedMessage(Result).FMsg;
      FMsgQueue.Delete(0);
      FHndMsgQueue.Add(Result);
      end;
  finally
    FLock.Leave;
    end;
end;

procedure TIdHL7.SendReply(AMsgHnd: TObject; AReply: String);
var
  qm: TQueuedMessage;
begin
  assert(Assigned(self));
  assert(Assigned(AMsgHnd));
  assert(AReply <> '', 'Attempt to send an empty reply'); {do not localize}
  assert(assigned(FLock));
  FLock.Enter;
  try
    qm := AMsgHnd as TQueuedMessage;
    qm.FReply := AReply;
    qm._Release;
    FHndMsgQueue.Delete(FHndMsgQueue.IndexOf(AMsgHnd));
  finally
    FLock.Leave;
    end;
  qm.FEvent.SetEvent;
end;

end.