Ok, das habe ich irgendwo zum Thema ThreadPool gelesen, erschien mir wichtig zu sein.
Das habe ich so weit korrigiert. Array ist weg.
Kann man mit dem Rest irgendwie leben?
Es muss nicht die optimale Lösung sein, doch etwas Craschsicher sollte es schon sein.
Für mich ist eben auch wichtig, dass ich den Code selbst verstehe und nachvollziehen kann, wo, was passiert.

Hier noch mal die Übersicht. Zum Thema Monitor habe ich noch nichts gelesen, ich gehe davon aus, dass mein CS1 und CS2 es korrekt abfangen.

zusammenfalten · markieren

Delphi-Quellcode:

    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormCanResize(Sender: TObject; var NewWidth, NewHeight: Integer; var Resize: Boolean);
    procedure FormDestroy(Sender: TObject);

    procedure ButtonStartClick(Sender: TObject);
    procedure ButtonAbbruchClick(Sender: TObject);
    procedure ButtonWeiterClick(Sender: TObject);
    procedure ButtonEXITClick(Sender: TObject);
  private
    { Private-Deklarationen }
    CSection1 : TCriticalSection;
    CSection2 : TCriticalSection;
    UrlList : TStringList;
    ErgebnisListe : TStringList;
    ActiveThreads : Int64;
    IdleJobs : Int64;
    JobsFinished : Int64;
    procedure UpdateLabelActiveThreads(Sender: TObject);
    procedure UpdateLabelJobs(Sender: TObject);
    procedure UpdateLabelFinished(Sender: TObject);

  public
    { Public-Deklarationen }
  end;

var
  Form1 : TForm1;
  ShouldStop : Boolean = False;

implementation

{$R *.dfm}

type
  TURLCheckerThread = class(TThread)
  private
    FUpdateAktiv : TNotifyEvent;
    FUpdateJobs : TNotifyEvent;
    FUpdateFertig : TNotifyEvent;
    FUrlList : TStrings;
    FCSection1 : TCriticalSection;
    FCSection2 : TCriticalSection;
    FOnStatus : TProc<TstringList>;
    FShouldStop : PBoolean;
    FTimeOut : Word;
  protected
    procedure Execute; override;
    procedure UpdateStatus(const Msg: TstringList);
  public
    constructor Create(UrlList: TStrings; CSection1, CSection2: TCriticalSection; OnStatus: TProc<TstringList>; ShouldStop: PBoolean; OnUpdateActive, OnUpdateJobs, OnUpdateFertig: TNotifyEvent; Timeout: Word);
  end;

{ TWorkerThread }
constructor TURLCheckerThread.Create(UrlList: TStrings; CSection1, CSection2: TCriticalSection; OnStatus: TProc<TstringList>; ShouldStop: PBoolean; OnUpdateActive, OnUpdateJobs, OnUpdateFertig: TNotifyEvent; Timeout: Word);
begin
  inherited Create(False);
  FUrlList := UrlList;
  FCSection1 := CSection1;
  FCSection2 := CSection2;
  FOnStatus := OnStatus;
  FShouldStop := ShouldStop;
  FreeOnTerminate := True;
  FTimeOut := Timeout;
  FUpdateAktiv := OnUpdateActive;
  FUpdateJobs := OnUpdateJobs;
  FUpdateFertig := OnUpdateFertig;
end;

procedure TURLCheckerThread.UpdateStatus(const Msg: TstringList);
begin
  if Assigned(FOnStatus) then
     TThread.Synchronize(TThread.Current, procedure begin FOnStatus(Msg); end);
end;

procedure TURLCheckerThread.Execute;
var
  FErgebnis : TstringList;
  Url : string;
  Http : TIdHTTP;
begin
  Http := TIdHTTP.Create(nil);
  Http.ConnectTimeout := FTimeOut;
  Http.ReadTimeout := FTimeOut;
    try
      while not Terminated and not FShouldStop^ do
        begin
          Url := '';

          FCSection1.Acquire;
            try
              if FUrlList.Count > 0 then
                begin
                  Url := FUrlList[0];
                  FUrlList.Delete(0);
                end;
            finally
              FCSection1.Release;
            end;

          if Url = '' then Break;

          Sleep(Random(2000)); {Hier kommt später meine Aufgabe}

          FErgebnis := TStringList.Create;
            try
              try
    // Http.Head(Url);

                FCSection2.Acquire; {Ich habe aber gelesen dass man StringList auf jeden Fall mit CriticalSection absichern soll}
                  try
                    FErgebnis.Add('OK: ' + Url); {Ergebnis in StringList eintragen}
                    FErgebnis.Add('Zweite Zeile');
                    FErgebnis.Add('Dritte Zeile');
                  finally
                    FCSection2.Release;
                  end;

                UpdateStatus(FErgebnis);
              except
                on E: Exception do
                  begin
                    FErgebnis.Add('FAIL: ' + Url + ' - ' + E.Message);
                    UpdateStatus(FErgebnis);
                  end;
              end;
            finally
              FreeAndNil(FErgebnis);
            end;

          if Assigned(FUpdateJobs) then
            begin
              TThread.Synchronize(nil, procedure
                begin
                  FUpdateJobs(Self);
                end);
            end;

          if Assigned(FUpdateFertig) then
            begin
              TThread.Synchronize(nil, procedure
                begin
                  FUpdateFertig(Self);
                end);
            end;
        end;
    finally
      FreeAndNil(FErgebnis);
      FreeAndNil(Http);

      if Assigned(FUpdateAktiv) then
        begin
          TThread.Synchronize(nil, procedure
            begin
              FUpdateAktiv(Self);
            end);
        end;
    end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  Icon : TIcon;
begin
  Icon := TIcon.Create;
  Icon.Handle := LoadIcon(hInstance, 'ICON_1');
  Form1.Icon := Icon;
  Icon.Free;
end;

procedure TForm1.FormShow(Sender: TObject);
var
  R : TRect;
begin
  Statusbar1.Perform($040A, 1, Integer(@R));
  Gauge1.Parent := Statusbar1;
  Gauge1.Top := r.Top + 2;
  Gauge1.Left := r.Left + 2;
  Gauge1.Width := r.Right - r.Left - 4;
  Gauge1.Height := r.Bottom - r.Top - 4;
end;

procedure TForm1.FormCanResize(Sender: TObject; var NewWidth, NewHeight: Integer; var Resize: Boolean);
begin
  FormShow(Sender); {Wiederverwenden der Logik, weil es genauso wie in TForm1.FormShow ist}
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FreeAndNil(ErgebnisListe);
  FreeAndNil(UrlList);
  FreeAndNil(CSection1);
  FreeAndNil(CSection2);
end;

procedure TForm1.ButtonStartClick(Sender: TObject);
var
  Threads : TURLCheckerThread;
  Index : Integer;
  Timeout : Word;
begin
  if Assigned(CSection1) then FreeAndNil(CSection1); {Falls ich nach Cancel noch mal Start drücke statt Weiter}
  if Assigned(CSection2) then FreeAndNil(CSection2);
  if Assigned(UrlList) then FreeAndNil(UrlList);

  UrlList := TStringList.Create;
  CSection1 := TCriticalSection.Create;
  CSection2 := TCriticalSection.Create;
  ShouldStop := False;

  for Index := 0 to 200 do
    begin
      URLList.Add('http://google.com/' + IntToStr(Index));
    end;

  LabelActiveThreads.Caption := '0';
  LabelJobs.Caption := '201';
  LabelIdle.Caption := '201';
  IdleJobs := 201;
  Gauge1.MaxValue := 201;
  Gauge1.Progress := 0;
  JobsFinished := 0;
  Timeout := SpinEditTimeout.Value * 1000;

  for Index := 1 to SpinEditThreads.Value do
    begin
      Threads := TURLCheckerThread.Create(UrlList, CSection1, CSection2,
        procedure(Msg: TstringList)
          var
            ErgebnisListe : TStringList;
          begin
            RichEditLog.Lines.Add(Msg.Text); {Ergebnis vom Thread als StringList}
          end, @ShouldStop, UpdateLabelActiveThreads, UpdateLabelJobs, UpdateLabelFinished, Timeout);

     {Zähle aktive Threads}
      Inc(ActiveThreads);
      LabelActiveThreads.Caption := IntToStr(ActiveThreads);
    end;
end;

procedure TForm1.ButtonWeiterClick(Sender: TObject);
var
  Threads : TURLCheckerThread;
  Index : Integer;
  Timeout : Word;
begin
  ShouldStop := False;
  Timeout := SpinEditTimeout.Value * 1000;

  for Index := 1 to SpinEditThreads.Value do
    begin
      Threads := TURLCheckerThread.Create(UrlList, CSection1, CSection2,
        procedure(Msg: TstringList)
          begin
            RichEditLog.Lines.Add(Msg.Text); {Ergebnis vom Thread als StringList}
          end, @ShouldStop, UpdateLabelActiveThreads, UpdateLabelJobs, UpdateLabelFinished, Timeout);

     {Zähle aktive Threads}
      Inc(ActiveThreads);
      LabelActiveThreads.Caption := IntToStr(ActiveThreads);
    end;
end;

procedure TForm1.ButtonAbbruchClick(Sender: TObject);
begin
  ShouldStop := True;
end;

procedure TForm1.ButtonEXITClick(Sender: TObject);
begin
  ShouldStop := True;
  Close;
end;

procedure TForm1.UpdateLabelActiveThreads;
begin
  Dec(ActiveThreads);
  LabelActiveThreads.Caption := IntToStr(ActiveThreads);
end;

procedure TForm1.UpdateLabelJobs(Sender: TObject);
begin
  Dec(Form1.IdleJobs);
  LabelIdle.Caption := IntToStr(IdleJobs);
end;

procedure TForm1.UpdateLabelFinished;
begin
  Inc(Form1.JobsFinished);
  LabelFinished.Caption := IntToStr(JobsFinished);
  Gauge1.Progress := Gauge1.Progress + 1;
end;

Zitat von jaenicke:

Ich habe einmal ein kleines Beispiel erstellt, siehe Anhang.

Sehr schönes Beispiel

Ich frage mich, weil es eine globale Funktion ist, welche von allen Seiten aus angefragt werden könnte,
ob es nicht threadsicherer würde, wenn man die Parameter klonen würde?

Also hier

zusammenfalten · markieren

Delphi-Quellcode:

class procedure TUrlChecker.Check( const AUrlList : TStrings;
                                   const AStatusCallback : TStatusCallback;
                                         ThreadCount : Integer;
                                   const AOnFinished : TFinishedCallback );
var
  LUrlList : TStringList;
begin
  LUrlList : TStringList.Create; // Better clone, to ensure higher threadsafety??
  LUrlList.AddStrings( AUrlList );

  TTask.Run(
    procedure
    var
        WorkQueue : TThreadedQueue< NativeUInt >;
        Tasks : TArray<ITask>;
        I : Integer;
    begin
      // Intern nur die Kopie LUrlList, statt AUrlList verwenden
      if not Assigned( LUrlList ) or not Assigned( AStatusCallback ) then
          Exit;
      ...

Ich habe bei der direkten Nutzung von Parametern wie AUrlList über zwei anonyme Funktionen hinweg immer so meine Bauchschmerzen, ob sich da drin zwischendurch nicht doch was verändert hat.

In der Praxis wird es wohl 100% ausreichen, weil man so eine Funktion ja nur an einer bestimmten Stelle nutzt, die man gut beobachten kann, normalerweise.
Aber falls nicht, dann "better safe than sorry", solche Fehler sind wohl schwer zu finden.

Oder gibt es gute Gründe dafür, dass ich mir hier zu viele Sorgen wegen der Parameter mache

Mit dem aktuellen Delphi 12 kannst du diesen impliziten Scope, der die Werte solcher Variablen enthält, direkt in der Variablenliste sehen. Das Feature ist echt gut. Das hilft denke ich beim Verständnis deutlich weiter.

Wenn du z.B. einen out-Parameter dort hättest, würdest du die Meldung bekommen, dass dieser Wert nicht erfasst werden kann. Denn da der Funktionsaufruf schon vorbei sein kann, kann man das nicht über den Scope abbilden.

Hier in diesem Fall hast du natürlich Recht:
Die Stringliste könnte nach dem Aufruf freigegeben oder verändert werden. Ich habe mich darauf verlassen, dass während der Laufzeit der Threads niemand das Memo ändert. Mit deiner Änderung könnte man das Problem umgehen.