Delphi-PRAXiS - Delphi Mal wieder Probleme mit Threads

Hallo,

kann mir mal bitte jemand sagen, wo in nachfolgendem Quellcode der Fehler
liegt? Ich bekomme gelegentlich (nicht immer!) die Fehlermeldung "EOS
Systemfehler Code 5. Zugriff verweigert" und/oder EAccessViolations. Ich
nutze Delphi 6 Professional.

Was will ich machen? Ich bilde im Hauptprogramm einen Thread
"ControlThread", der nichts anderes macht, als bis zur Maximalzahl
festgelegte Anzahl an "OnlineThreads" zu bilden. Ist die Maximalzahl an
Onlinethreads erreicht, wartet ControlThread auf die Beendigung von
Online-Threads und startet dann neue OnlineThreads (eben solange, bis das
letzte Element der verketteten Liste erreicht ist).

Delphi-Quellcode:

			| unit online;

|

| interface

|

| uses

|   Classes, data, SyncObjs;

|

| type

|   TNotifyEvent = procedure(Sender: TObject; ThreadCount: integer) of object;

|

|   TOnlineThread = class(TThread)

|   private

|     { Private-Deklarationen }

|   protected

|     procedure Execute; override;

|   public

|     URL: PURL;

|     constructor Create(CreateSuspended:boolean);

|   end;

|

|   TControlThread = class(TThread)

|   private

|     { Private-Deklarationen }

|     ThreadCount   : integer;

|     aktuell       : PURL;

|     FOnNotify     : TNotifyEvent;

|     ControlCriticalSection : TCriticalSection;

|     procedure OnlineThreadStopped(Sender: TObject);

|   protected

|     procedure Execute; override;

|     procedure Notify; virtual;

|   public

|     FirstURL: PURL;

|     constructor Create(CreateSuspended:boolean);

|     property OnNotify: TNotifyEvent read FOnNotify write FOnNotify;

|   end;

|

| implementation

|

| uses

|   constants, SysUtils;

|

| constructor TOnlineThread.Create(CreateSuspended:Boolean);

| begin

|   inherited Create(CreateSuspended);

|   URL := nil;

| end;

|

| procedure TOnlineThread.Execute;

| begin

|   URL^.getStatusHead;                // Status der URL abfragen

| end;

|

|

| constructor TControlThread.Create(CreateSuspended:boolean);

| begin

|   inherited Create(CreateSuspended);

|   FOnNotify := nil;

|   FirstURL := nil;

|   ThreadCount := 0;

|   ControlCriticalSection := TCriticalSection.Create;

| end;

|

| procedure TControlThread.Notify;

| { Hierbei handelt es sich um ein Event, welches vom Hauptprogramm

|   abgefragt werden kann, um die anzahl der laufenden Online-Threads

|   zu erfahren }

| begin

|   if Assigned(FOnNotify) then

|       FOnNotify(self,ThreadCount)

|   {end if};

| end;

|

| procedure TControlThread.OnlineThreadStopped(Sender: TObject);

| // Thread freigeben

| // und Anzahl der laufenden Threads aktualisieren

| begin

|   ControlCriticalSection.Acquire;

|   Dec(ThreadCount);

|   ControlCriticalSection.Release;

|   (Sender as TOnlineThread).Free;

| end;

|

| procedure TControlThread.Execute;

| var

|   newthread : TOnlineThread;

| begin

|   aktuell := FirstURL;

|   while (not Terminated) do

|     begin

|       while (aktuell<>nil) and (not Terminated) do

|         begin

|           if ThreadCount>=MAXIMUM_THREADS then

|             Sleep(100)     // 100 ms warten, wenn die max. Anzahl an Online-Threads erreicht

|           else

|             begin

|               newthread := TOnlineThread.Create(true);

|               newthread.FreeOnTerminate := false;

|               newthread.OnTerminate := OnlineThreadStopped;

|               newthread.URL := aktuell;

|               ControlCriticalSection.Acquire;

|               Inc(ThreadCount);

|               ControlCriticalSection.Release;

|

|               Synchronize(Notify);

|               aktuell := aktuell^.next;

|               newthread.Resume;

|             end

|           {end if};

|         end

|       {end while};

|       if aktuell=nil then

|         begin

|           Sleep(100);   // 100 ms warten bis zum nächsten nachschauen, ob Thread beendet werden darf

|           Synchronize(Notify);

|           if ThreadCount<=0 then

|             Terminate   // ControlThread beenden, wenn keine weitere Adresse mehr vorliegt

|           {end if};

|         end

|       {end if};

|     end

|   {end while};

| end;

|

| end.

In der Unit "data" habe ich die Klasse TURL definiert, inklusive aller
Methoden. Die Daten, die auch von außen abgefragt werden, sind dabei mit
einer CriticalSection (wird global im Hauptprogramm definiert) geschützt,
sollten also doch normalerweise Threadsicher sein? (Listing auf das
Relevante gekürzt)

Delphi-Quellcode:

			| unit data;

|

| interface

|

| uses

|   classes, graphics, msxml2_tlb, SyncObjs;

|   

| type

|   PURL = ^TURL;

|

|   TURL = class

|   private

|     { Private-Deklarationen }

|     FURL                    : string;

|     FStatus                 : string;

|     FStatus_Text            : string;

|     FStatusWWW              : string;

|     FStatusWWW_Text         : string;

|     FZeit                   : TDateTime;

|     Fnext                   : PURL;

|     Fprev                   : PURL;

|     CriticalSection         : TCriticalSection;

|     function ConnectToServer(Request,URL:String) : String;

|     procedure Lock;

|     procedure Unlock;

|   protected

|     function GetURL : string;

|     function GetStatus : string;

|     function GetStatus_Text : string;

|     function GetStatusWWW : string;

|     function GetStatusWWW_Text : string;

|     function GetZeitalsString : string;

|     function GetNext : PURL;

|     function GetPrev : PURL;

|     procedure SetURL (URL: string);

|     procedure SetNext (Next: PURL);

|     procedure SetPrev (Prev: PURL);

|   public

|     { Public-Deklarationen }

|     constructor Create(CriticalSection: TCriticalSection);

|     procedure LoadFromLine(Line: String);

|     procedure GetStatusHead;

|     procedure SaveXML(Node: IXMLDOMNode);

|     procedure LoadXML(Node: IXMLDOMNode);

|     property URL : string read GetURL write SetURL;

|     property Status : string read GetStatus;

|     property Status_Text : string read GetStatus_Text;

|     property StatusWWW : string read GetStatusWWW;

|     property StatusWWW_Text : string read GetStatusWWW_Text;

|     property Zeit : TDateTime read FZeit;

|     property ZeitalsString : String read GetZeitalsString;

|     property Next : PURL read GetNext write SetNext;

|     property Prev : PURL read GetPrev write SetPrev;

|   end;

|

| const

|   CELEMENT          = 'url';

|   CURL              = 'url';

|   CStatus           = 'status';

|   CStatus_Text      = 'statustext';

|   CStatusWWW        = 'wwwstatus';

|   CStatusWWW_Text   = 'wwwstatustext';

|   CDatum            = 'datum';

|

| implementation

|

| uses

|   constants, IdGlobal, ScktComp, SysUtils, XMLops;

|

|

| procedure TURL.Lock;

| begin

|   CriticalSection.Acquire;

| end;

|

| procedure TURL.Unlock;

| begin

|   CriticalSection.Release;

| end;

|

| function TURL.GetURL : string;

| begin

|   Lock;

|   Result := FURL;

|   Unlock;

| end;

|

| function TURL.GetStatus : string;

| begin

|   Lock;

|   Result := FStatus;

|   Unlock;

| end;

|

| function TURL.GetStatus_Text : string;

| begin

|   Lock;

|   Result := FStatus_Text;

|   Unlock;

| end;

|

| function TURL.GetStatusWWW : string;

| begin

|   Lock;

|   Result := FStatusWWW;

|   Unlock;

| end;

|

| function TURL.GetStatusWWW_Text : string;

| begin

|   Lock;

|   Result := FStatusWWW_Text;

|   Unlock;

| end;

|

| function TURL.GetZeitalsString : string;

| begin

|   Lock;

|   if FZeit>0 then

|     Result := FormatDateTime('dd.mm.yyyy hh:nn:ss',FZeit)

|   else

|     Result := ''

|   {end if};

|   Unlock;

| end;

|

| function TURL.GetNext : PURL;

| begin

|   Lock;

|   Result := FNext;

|   Unlock;

| end;

|

| function TURL.GetPrev : PURL;

| begin

|   Lock;

|   Result := FPrev;

|   Unlock;

| end;

|

| procedure TURL.SetURL (URL: string);

| begin

|   Lock;

|   FURL := URL;

|   Unlock;

| end;

|

| procedure TURL.SetNext (Next: PURL);

| begin

|   Lock;

|   FNext := Next;

|   Unlock;

| end;

|

| procedure TURL.SetPrev (Prev: PURL);

| begin

|   Lock;

|   FPrev := Prev;

|   Unlock;

| end;

|

| function TURL.ConnectToServer(Request,URL:String) : String;

| var

|   ClientSocket : TClientSocket;

|   SockStream: TWinSocketStream;

|   Buffer: Array[0..1024] of char;

|   Ergebnis: string;

|   now:Cardinal;

|   FData:String;

| begin

|   Ergebnis := '';

|   ClientSocket := TClientSocket.Create(nil);

|   ClientSocket.Port := 80;

|   ClientSocket.Host := URL;

|   ClientSocket.ClientType := ctBlocking;

|   try

|     ClientSocket.Open;

|     SockStream := TWinSocketStream.Create(ClientSocket.Socket,60000);

|     SockStream.Write(Request[1], Length(Request));

|

|     now := gettickcount;

|

|     while (SockStream.Read(Buffer, SizeOf(Buffer)) <> 0) do

|       begin

|         FData := FData + Buffer;

|         FillChar(Buffer, SizeOf(Buffer), #0);

|         // Überprüfen, ob TimeOut erreicht oder Socket geschlossen

|         if (gettickcount > now+TIMEOUT) or not ClientSocket.Active then

|           Exit

|         {end if};

|       end;

|     {end while};

|     ClientSocket.Socket.Close;

|     SockStream.Free;

|     if Trim(FData)<>'' then

|       begin

|         if Pos('HTTP/1.',FData)>0 then

|           Ergebnis := Copy(FData,10,9999)

|         else

|           Ergebnis := FData

|         {end if};

|         Ergebnis := Copy(Ergebnis,1,Pos(#13,Ergebnis)-1);

|       end

|     else

|       Ergebnis := 'ERR ERR HOST NOT FOUND'

|     {end if};

|   except

|     Ergebnis := Ergebnis + 'ERR ERR HOST NOT FOUND';

|   end;

|   ClientSocket.Active := false;

|   ClientSocket.Close;

|   ClientSocket.Free;

|   Result := Ergebnis;

| end;

|

| constructor TURL.Create(CriticalSection: TCriticalSection);

| begin

|   inherited Create;

|   Self.CriticalSection := CriticalSection;

|   FURL := '';

|   FStatus := '';

|   FStatus_Text := '';

|   FStatusWWW := '';

|   FStatusWWW_Text := '';

|   Fnext := nil;

|   Fprev := nil;

| end;

|

| procedure TURL.LoadFromLine(Line: String);

| // Liest die Daten aus der Datei, die vom Unix-Script check.sh angelegt wurde

| // oder welche nur die Domainnamen enthält

| var

|   Position : integer;

| begin

|   Lock;

|   Position := Pos(' : ',Line);

|   if Position<>0 then

|     begin  // Daten aus check.sh

|       FURL := Copy(Line,1,Position-1);

|       FStatus := Copy(Line,Position+3,3);

|       FStatus_Text := Copy(Line,Position+7,9999);

|     end

|   else

|     begin  // Daten aus Domain-Liste

|       FURL := Line;

|     end

|   {end if};

|   Unlock;

| end;

|

| procedure TURL.GetStatusHead;

| var

|   RequestString: string;

|   Dummy        : string;

| begin

|   RequestString:='HEAD / HTTP/1.1'#13#10;

|   RequestString := RequestString+'User-Agent: xxx'#13#10;

|   RequestString := RequestString+'Host: www.'+FURL+#13#10;

|   RequestString := RequestString+'Connection: close'#13#10#13#10#13#10;

|   Dummy := ConnectToServer(RequestString,'www.'+FURL);

|   Lock;             // Holen und Eintrag in Variable gesplittet, um Lock-Zeit möglichst kurz zu halten

|   FStatusWWW := Copy(Dummy,1,3);

|   FStatusWWW_Text := Copy(Dummy,5,9999);

|   Unlock;

|

|   RequestString:='HEAD / HTTP/1.1'#13#10;

|   RequestString := RequestString+'User-Agent: xxx'#13#10;

|   RequestString := RequestString+'Host: '+FURL+#13#10;

|   RequestString := RequestString+'Connection: close'#13#10#13#10#13#10;

|   Dummy := ConnectToServer(RequestString,FURL);

|   Lock;             // Holen und Eintrag in Variable gesplittet, um Lock-Zeit möglichst kurz zu halten

|   FStatus := Copy(Dummy,1,3);

|   FStatus_Text := Copy(Dummy,5,9999);

|   FZeit := now;

|   Unlock;

| end;