Dienst wird durch Leerlauf beendet

[CalganX]

Update: Siehe ersten Antwortpost.

Hi,
ich habe gerade einige Probleme mit einem Dienst, der zwei Threads beherbergt. Der Sinn ist, dass der Dienst im Hintergrund läuft, während der Thread darauf wartet, dass über Sockets Anfragen hereinkommen, die dann über einen zweiten Thread beantwortet werden.
Dazu ein wenig Code:

Service/Dienst:

Delphi-Quellcode:

procedure TsrvMain.ServiceCreate(Sender: TObject);
begin
  // TCP-Server erzeugen
  FTCPDaemon := TTCPDaemon.Create;
end;

procedure TsrvMain.ServiceExecute(Sender: TService);
begin
  // TCP-Server starten (FIXME: Testweise auskommentiert)
//  FTCPDaemon.Execute;
end;

procedure TsrvMain.ServiceDestroy(Sender: TObject);
begin
  // Und weg damit
  FTCPDaemon.Free;
end;

Warte-Thread:

Delphi-Quellcode:

constructor TTCPDaemon.Create;
begin
  inherited Create(false);

  FSock := TTCPBlockSocket.Create;
  FreeOnTerminate := true;
end;

destructor TTCPDaemon.Destroy;
begin
  FSock.Free;

  inherited;
end;

procedure TTCPDaemon.Execute;
var
  ClientSocket: TSocket;
begin
  inherited;

  FSock.CreateSocket;
  FSock.SetLinger(true,10);
  FSock.Bind('0.0.0.0', '1308');
  FSock.Listen;

  repeat
    if self.Terminated then Break;

    if FSock.CanRead(500) then begin
      ClientSocket := FSock.Accept;
      if FSock.LastError = 0 then
        TTCPReplyThread.Create(ClientSocket);
    end;
  until false;
end;

Antwort-Thread:

Delphi-Quellcode:

constructor TTCPReplyThread.Create(HSock: TSocket);
begin
  inherited Create(false);

  FSock := TTCPBlockSocket.Create;
  FSock.Socket := HSock;
  FreeOnTerminate := true;
end;

destructor TTCPReplyThread.Destroy;
begin
  FSock.Free;

  inherited;
end;

procedure TTCPReplyThread.Execute;
var
  s: string;
  TunesApp: IiTunes;
begin
  inherited;

  FSock.GetSins;

  repeat
    if self.Terminated then
      break;

    s := LowerCase(FSock.RecvPacket(5000));
    if FSock.LastError <> 0 then
      break;

    CoInitialize(nil);
    TunesApp := CoiTunesApp.Create;
    try
      { Hier wird auf "s" reagiert und entsprechend mit FSock.SendString(); eine Antwort geschickt. Bspw.:}
      if s = IDS_CURRENT_TRACKNAME then
      begin
        if (TunesApp <> nil) and (TunesApp.CurrentTrack <> nil) then
          FSock.SendString(TunesApp.CurrentTrack.Name);
      end;
    finally
      TunesApp := nil;
      CoUninitialize;
    end;

    if FSock.LastError <> 0 then
      break;
  until false;
end;

Der Client sendet alle 5 Sekunden entsprechende Anfragen an den Server, auf dem der Dienst läuft. Bisher hat das immer wunderbar funktioniert, nur seitdem ich die Threads in einem Dienst laufen lassen will, funktioniert es nicht mehr so richtig.
Problem ist, dass mir gelegentlich (meist beim dritten oder vierten Mal) Zugriffsverletzungen um die Ohren gehauen werden.

Gibt es dafür irgendeinen sinnigen Grund?

Chris

[CalganX]

Hi nochmal,
okay. Habe jetzt das Problem gefunden: der Dienst beendet sich selber. Ich nehme an, weil er meint, sich im Leerlauf zu befinden, obwohl der Thread noch weiter ackern sollte. Nehme ich das FTCPDaemon.Free; heraus gibt es keine AV mehr, sondern der Thread geht einfach so zu Ende.

Ich habe deswegen in mein OnExecute-Ereignis des Dienstes folgende Schleife rein geschrieben:

Delphi-Quellcode:

  while not Terminated do
  begin
    ServiceThread.ProcessRequests(true);
  end;

Hilft aber auch nicht.

Chris