idhl7.pas

Indy控件的使用源代码

  case AResult of
    srNone: 
      raise EHL7CommunicationError.Create(Name, 'Internal error in IdHL7.pas: SynchronousSend returned srNone');
    srError: 
      raise EHL7CommunicationError.Create(Name, AMsg);
    srNoConnection: 
      raise EHL7CommunicationError.Create(Name, 'Not connected');
    srSent: 
      raise EHL7CommunicationError.Create(Name, 'Internal error in IdHL7.pas: SynchronousSend returned srSent');  // cause this should only be returned asynchronously
    srOK:; // all ok
    srTimeout: 
      raise EHL7CommunicationError.Create(Name, 'No response from remote system');
    else
      raise EHL7CommunicationError.Create(Name, 'Internal error in IdHL7.pas: SynchronousSend returned an unknown value ' + IntToStr(Ord(AResult)));
    end;
end;

{ TIdHL7PeerThread }

constructor TIdHL7PeerThread.Create(ACreateSuspended: Boolean);
begin
  inherited;
  FBuffer := '';
end;

// well, this doesn't do anything. but declared for consistency
destructor TIdHL7PeerThread.Destroy;
begin
  assert(assigned(self));
  inherited;
end;

procedure TIdHL7.CheckServerParameters;
begin
  assert(assigned(self));
  if (FCommunicationMode = cmAsynchronous) or not FIsListener then
    begin
    FConnectionLimit := 1;
    end;

  if (FPort < 1) then // though we have already ensured that this cannot happen
    begin
    raise EHL7CommunicationError.Create(Name, Format(RSHL7InvalidPort, [FPort]));
    end;
end;

procedure TIdHL7.StartServer;
begin
  assert(assigned(self));
  CheckServerParameters;
  FServer := TIdTCPServer.Create(NIL);
  try
    FServer.DefaultPort := FPort;
    FServer.ThreadClass := TIdHL7PeerThread;
    Fserver.OnConnect := ServerConnect;
    FServer.OnExecute := ServerExecute;
    FServer.OnDisconnect := ServerDisconnect;
    FServer.Active := True;
    InternalSetStatus(IsNotConnected, RSHL7StatusNotConnected);
  except
    on e:
    Exception do
      begin
      InternalSetStatus(IsStopped, Format(RSHL7StatusFailedToStart, [e.message]));
      FreeAndNil(FServer);
      raise;
      end;
    end;
end;

procedure TIdHL7.StopServer;
begin
  assert(assigned(self));
  try
    FServer.Active := False;
    FreeAndNil(FServer);
    InternalSetStatus(IsStopped, RSHL7StatusStopped);
  except
    on e: 
    Exception do
      begin
      // somewhat arbitrary decision: if for some reason we fail to shutdown,
      // we will stubbornly refuse to work again.
      InternalSetStatus(IsUnusable, Format(RSHL7StatusFailedToStop, [e.message]));
      FServer := NIL;
      raise
      end;
    end;
end;

procedure TIdHL7.ServerConnect(AThread: TIdPeerThread);
var
  LNotify: Boolean;
  LConnCount: Integer;
  LValid: Boolean;
begin
  assert(assigned(self));
  assert(assigned(AThread));
  assert(assigned(FLock));
  FLock.Enter;
  try
    LNotify := FConnCount = 0;
    inc(FConnCount);
    LConnCount := FConnCount;
    // it would be better to stop getting here in the case of an invalid connection
    // cause here we drop it - nasty for the client. To be investigated later
    LValid := FConnCount <= FConnectionLimit;
    if (FConnCount = 1) and (FCommunicationMode <> cmAsynchronous) and not IsListener then
      begin
      FServerConn := AThread.Connection;
      end;
    if LNotify then
      begin
      InternalSetStatus(IsConnected, RSHL7StatusConnected);
      end;
  finally
    FLock.Leave;
    end;
  if LValid then
    begin
    if LNotify and assigned(FOnConnect) then
      begin
      FOnConnect(self);
      end;
    if assigned(FOnConnCountChange) and (FConnectionLimit <> 1) then
      begin
      FOnConnCountChange(Self, LConnCount);
      end;
    end
  else
    begin
    // Thread exceeds connection limit
    AThread.Connection.Disconnect;
    end;
end;

procedure TIdHL7.ServerDisconnect(AThread: TIdPeerThread);
var
  LNotify: Boolean;
  LConnCount: Integer;
begin
  assert(assigned(self));
  assert(assigned(AThread));
  assert(assigned(FLock));
  FLock.Enter;
  try
    dec(FConnCount);
    LNotify := FConnCount = 0;
    LConnCount := FConnCount;
    if AThread.Connection = FServerConn then
      begin
      FServerConn := NIL;
      end;
    if LNotify then
      begin
      InternalSetStatus(IsNotConnected, RSHL7StatusNotConnected);
      end;
  finally
    FLock.Leave;
    end;
  if assigned(FOnConnCountChange) and (FConnectionLimit <> 1) then
    begin
    FOnConnCountChange(Self, LConnCount);
    end;
  if LNotify and assigned(FOnDisconnect) then
    begin
    FOnDisconnect(self);
    end;
end;

procedure TIdHL7.ServerExecute(AThread: TIdPeerThread);
var
  LThread: TIdHL7PeerThread;
  FSize: Integer;
  FStream: TStringStream;
begin
  assert(assigned(self));
  assert(assigned(AThread));
  LThread := AThread as TIdHL7PeerThread;
  FStream := TStringStream.Create('');
  try
    try
      // 1. prompt the network for content.
      LThread.Connection.ReadFromStack(False, -1, False);
    except
      try
        // well, there was some network error. We aren't sure what it
        // was, and it doesn't matter for this layer. we're just going
        // to make sure that we start again.
        // to review: what happens to the error messages?
        LThread.Connection.DisconnectSocket;
      except
        end;
      exit;
      end;
    FSize := LThread.Connection.InputBuffer.Size;
    if FSize > 0 then
      begin
      FStream.Size := 0;
      LThread.Connection.ReadStream(FStream, FSize);
      LThread.FBuffer := LThread.FBuffer + FStream.DataString;
      HandleIncoming(LThread.FBuffer, LThread.Connection);
      end;
  finally
    FreeAndNil(FStream)
    end;
end;

procedure TIdHL7.DropServerConnection;
begin
  assert(assigned(self));
  assert(assigned(FLock));
  FLock.Enter;
  try
    if assigned(FServerConn) then
      FServerConn.Disconnect;
  finally
    FLock.Leave;
    end;
end;


{==========================================================
  Client Connection Maintainance
 ==========================================================}

procedure TIdHL7.CheckClientParameters;
begin
  assert(assigned(self));
  if (FPort < 1) then
    begin
    raise EHL7CommunicationError.Create(Name, Format(RSHL7InvalidPort, [FPort]));
    end;
end;

procedure TIdHL7.StartClient;
begin
  assert(assigned(self));
  CheckClientParameters;
  FClientThread := TIdHL7ClientThread.Create(self);
  InternalSetStatus(isConnecting, RSHL7StatusConnecting);
end;

procedure TIdHL7.StopClient;
var
  LFinished: Boolean;
  LStartTime : Cardinal;
begin
  assert(assigned(self));
  assert(assigned(FLock));
  FLock.Enter;
  try
    FClientThread.Terminate;
    FClientThread.FClient.DisconnectSocket;
    FClientThread.FCloseEvent.SetEvent;
  finally
    FLock.Leave;
    end;
  LStartTime := GetTickCount;
  repeat
    LFinished := (GetStatus = IsStopped);
    if not LFinished then
      begin
      sleep(10);
      end;
  until LFinished or (GetTickDiff(LStartTime,GetTickCount) > WAIT_STOP);
  if GetStatus <> IsStopped then
    begin
    // for some reason the client failed to shutdown. We will stubbornly refuse to work again
    InternalSetStatus(IsUnusable, Format(RSHL7StatusFailedToStop, [RSHL7ClientThreadNotStopped]));
    end;
end;

procedure TIdHL7.DropClientConnection;
begin
  assert(assigned(self));
  assert(assigned(FLock));
  FLock.Enter;
  try
    if assigned(FClientThread) and assigned(FClientThread.FClient) then
      begin
      FClientThread.FClient.DisconnectSocket
      end
    else
      begin
      // This may happen validly because both ends are trying to drop the connection simultaineously
      end;
  finally
    FLock.Leave;
    end;
end;

{ TIdHL7ClientThread }

constructor TIdHL7ClientThread.Create(aOwner: TIdHL7);
begin
  assert(assigned(AOwner));
  FOwner := aOwner;
  FCloseEvent := TIdLocalEvent.Create(True, False);
  FreeOnTerminate := True;
  inherited Create(False);
end;

destructor TIdHL7ClientThread.Destroy;
begin
  assert(assigned(self));
  assert(assigned(FOwner));
  assert(assigned(FOwner.FLock));
  FreeAndNil(FCloseEvent);
  try
    FOwner.FLock.Enter;
    try
      FOwner.FClientThread := NIL;
      FOwner.InternalSetStatus(isStopped, RSHL7StatusStopped);
    finally
      FOwner.FLock.Leave;
      end;
  except
    // it's really vaguely possible that the owner
    // may be dead before we are. If that is the case, we blow up here.
    // who cares.
    end;
  inherited;
end;

procedure TIdHL7ClientThread.PollStack;
var
  LBuffer: String;
  FSize: Integer;
  FStream: TStringStream;
begin
  assert(assigned(self));
  FStream := TStringStream.Create('');
  try
    LBuffer := '';
    repeat
      // we don't send here - we just poll the stack for content
      // if the application wants to terminate us at this point,
      // then it will disconnect the socket and we will get thrown
      // out
      // we really don't care at all whether the disconnect was clean or ugly

      // but we do need to suppress exceptions that come from
      // indy otherwise the client thread will terminate

      try
        // 1. prompt the network for content.
        FClient.ReadFromStack(False, -1, False);
      except
        try
          // well, there was some network error. We aren't sure what it
          // was, and it doesn't matter for this layer. we're just going
          // to make sure that we start again.
          // to review: what happens to the error messages?
          FClient.DisconnectSocket;
        except
          end;
        exit;
        end;
      FSize := FClient.InputBuffer.Size;
      if FSize > 0 then
        begin
        FStream.Size := 0;
        FClient.ReadStream(FStream, FSize);
        LBuffer := LBuffer + FStream.DataString;
        FOwner.HandleIncoming(LBuffer, FClient);
        end;
    until Terminated or not FClient.Connected;
  finally
    FStream.Free;
    end;
end;

procedure TIdHL7ClientThread.Execute;
var 
  LRecTime: TDateTime;
begin
  assert(assigned(self));
  try
    FClient := TIdTCPClient.Create(NIL);
    try
      FClient.Host := FOwner.FAddress;
      FClient.Port := FOwner.FPort;
      repeat
        // try to connect. Try indefinitely but wait Owner.FReconnectDelay
        // between attempts. Problems: how long does Connect take?
        repeat
          FOwner.InternalSetStatus(IsConnecting, rsHL7StatusConnecting);
          try
            FClient.Connect;
          except
            on e: 
            Exception do
              begin
              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;