ThreadControl.pas

   1 unit ThreadControl;
   2
   3 interface
   4
   5 uses
   6         SysUtils, Classes, Controls, Forms, IdHTTP, IdComponent,
   7         {HTTPApp,} YofUtils, GikoSystem, BoardGroup, ItemDownload;
   8
   9 type
  10         TThreadControl = class(TThread)
  11         private
  12                 FItemList: TThreadList;                                 // \83_\83E\83\93\83\8d\81[\83h\82·\82é\83A\83C\83e\83\80\82ð\8ai\94[\82·\82é\83\8a\83X\83g
  13                 FAbort: Boolean;                                                                // \92\86\92f\83t\83\89\83O
  14                 FThreadList: TList;                                                     // \8eÀ\8dÛ\82É\83_\83E\83\93\83\8d\81[\83h\82·\82é\83X\83\8c\83b\83h\83I\83u\83W\83F\83N\83g\82Ì\83\8a\83X\83g
  15                 FMaxThreadCount: Integer;                               // \8dÅ\91å\83X\83\8c\83b\83h\90\94
  16                 FOnWork: TGikoWorkEvent;
  17                 FOnWorkBegin: TGikoWorkBeginEvent;
  18                 FOnWorkEnd: TGikoWorkEndEvent;
  19                 FOnDownloadEnd: TDownloadEndEvent;
  20                 FOnDownloadMsg: TDownloadMsgEvent;
  21                 procedure WorkBegin(Sender: TObject; AWorkMode: TWorkMode; const AWorkCountMax: Integer; Number: Integer; const AWorkTitle: string);
  22                 procedure WorkEnd(Sender: TObject; AWorkMode: TWorkMode; Number: Integer);
  23                 procedure Work(Sender: TObject; AWorkMode: TWorkMode; const AWorkCount: Integer; Number: Integer);
  24                 procedure DownloadEnd(Sender: TObject; Item: TDownloadItem);
  25                 procedure DownloadMsg(Sender: TObject; Item: TDownloadItem; Msg: string; Icon: TGikoMessageIcon);
  26                 procedure SetMaxThreadCount(Count: Integer);
  27         protected
  28                 procedure Execute; override;
  29         public
  30                 constructor Create(CreateSuspended: Boolean);
  31                 destructor Destroy; override;
  32                 procedure AddItem(Item: TDownloadItem);
  33                 function GetSuspendThread: TDownloadThread;
  34                 function GetActiveThreadCount: Integer;
  35                 procedure DownloadAbort;
  36                 property MaxThreadCount: Integer read FMaxThreadCount write SetMaxThreadCount;
  37                 property OnWork: TGikoWorkEvent read FOnWork write FOnWork;
  38                 property OnWorkBegin: TGikoWorkBeginEvent read FOnWorkBegin write FOnWorkBegin;
  39                 property OnWorkEnd: TGikoWorkEndEvent read FOnWorkEnd write FOnWorkEnd;
  40                 property OnDownloadEnd: TDownloadEndEvent read FOnDownloadEnd write FOnDownloadEnd;
  41                 property OnDownloadMsg: TDownloadMsgEvent read FOnDownloadMsg write FOnDownloadMsg;
  42         end;
  43
  44 implementation
  45
  46 constructor TThreadControl.Create(CreateSuspended: Boolean);
  47 begin
  48         inherited Create(CreateSuspended);
  49         FItemList := TThreadList.Create;
  50         FThreadList := TList.Create;
  51
  52         FAbort := False;
  53 end;
  54
  55 destructor TThreadControl.Destroy;
  56 var
  57         i: Integer;
  58 begin
  59     FThreadList.Pack;
  60         for i := FThreadList.Count - 1 downto 0 do begin
  61         TDownloadThread(FThreadList[i]).Free;
  62         end;
  63     FThreadList.Capacity := FThreadList.Count;
  64         FThreadList.Free;
  65     FItemList.Clear;
  66         FItemList.Free;
  67         inherited;
  68 end;
  69
  70 procedure TThreadControl.AddItem(Item: TDownloadItem);
  71 begin
  72         FItemList.Add(Item);
  73 end;
  74
  75 procedure TThreadControl.Execute;
  76 var
  77         List: TList;
  78         i: Integer;
  79         FDownThread: TDownloadThread;
  80 begin
  81         while not Terminated do begin
  82                 Sleep(10);
  83                 List := FItemList.LockList;
  84                 try
  85                         if List.Count > 0 then begin
  86                                 FDownThread := GetSuspendThread;
  87                                 if FDownThread <> nil then begin
  88                                         FDownThread.Item := TDownloadItem(List.Items[0]);
  89                                         List.Delete(0);
  90                                         FDownThread.Resume;
  91                                 end;
  92                         end;
  93                 finally
  94                         FItemList.UnlockList;
  95                 end;
  96                 if FAbort then begin
  97                         for i := 0 to FThreadList.Count - 1 do begin
  98                                 if not TDownloadThread(FThreadList[i]).Suspended then
  99                                         TDownloadThread(FThreadList[i]).Abort;
 100                         end;
 101                         List := FItemList.LockList;
 102                         try
 103                                 List.Clear;
 104                         finally
 105                                 FItemList.UnlockList;
 106                         end;
 107                         FAbort := False;
 108                 end;
 109         Application.ProcessMessages;
 110         end;
 111     // \8ec\82Á\82Ä\82¢\82é\83X\83\8c\83b\83h\82ð\91S\82Ä\8fI\97¹\82³\82¹\82é\81B
 112         for i := 0 to FThreadList.Count - 1 do begin
 113         TDownloadThread(FThreadList[i]).Abort;
 114                 TDownloadThread(FThreadList[i]).Terminate;
 115                 if TDownloadThread(FThreadList[i]).Suspended then begin
 116                         TDownloadThread(FThreadList[i]).Resume;
 117             TDownloadThread(FThreadList[i]).WaitFor;
 118         end;
 119         end;
 120
 121 end;
 122
 123 function TThreadControl.GetSuspendThread: TDownloadThread;
 124 var
 125         i: Integer;
 126         DownloadThread: TDownloadThread;
 127 begin
 128         Result := nil;
 129         if GetActiveThreadCount >= FMaxThreadCount then Exit;
 130         for i := 0 to FThreadList.Count - 1 do begin
 131                 if TDownloadThread(FThreadList[i]).Suspended then begin
 132                         Result := TDownloadThread(FThreadList[i]);
 133                         Break;
 134                 end;
 135         end;
 136         if (Result = nil) and (FMaxThreadCount > FThreadList.Count) then begin
 137                 DownloadThread := TDownloadThread.Create(True);
 138                 DownloadThread.FreeOnTerminate := False;
 139                 DownloadThread.Number := FThreadList.Count;
 140                 DownloadThread.OnWorkBegin := WorkBegin;
 141                 DownloadThread.OnWorkEnd := WorkEnd;
 142                 DownloadThread.OnWork := Work;
 143                 DownloadThread.OnDownloadEnd := DownloadEnd;
 144                 DownloadThread.OnDownloadMsg := DownloadMsg;
 145                 FThreadList.Add(DownloadThread);
 146                 Result := DownloadThread;
 147         end;
 148 end;
 149
 150 function TThreadControl.GetActiveThreadCount: Integer;
 151 var
 152         i: Integer;
 153 begin
 154         Result := 0;
 155         for i := 0 to FThreadList.Count - 1 do begin
 156                 if not TDownloadThread(FThreadList[i]).Suspended then
 157                         Inc(Result);
 158         end;
 159 end;
 160
 161 procedure TThreadControl.DownloadAbort;
 162 begin
 163         FAbort := True;
 164 end;
 165
 166 procedure TThreadControl.SetMaxThreadCount(Count: Integer);
 167 begin
 168         if FMaxThreadCount = Count then Exit;
 169         if Count <= 0 then Count := 1;
 170         if Count > 10 then Count := 10;
 171         FMaxThreadCount := Count;
 172 end;
 173
 174 procedure TThreadControl.WorkBegin(Sender: TObject; AWorkMode: TWorkMode; const AWorkCountMax: Integer; Number: Integer; const AWorkTitle: string);
 175 begin
 176         if Assigned(OnWorkBegin) then
 177                 OnWorkBegin(Sender, AWorkMode, AWorkCountMax, Number, AWorkTitle);
 178 end;
 179
 180 procedure TThreadControl.WorkEnd(Sender: TObject; AWorkMode: TWorkMode; Number: Integer);
 181 begin
 182         if Assigned(OnWorkEnd) then
 183                 OnWorkEnd(Sender, AWorkMode, Number);
 184 end;
 185
 186 procedure TThreadControl.Work(Sender: TObject; AWorkMode: TWorkMode; const AWorkCount: Integer; Number: Integer);
 187 begin
 188         if Assigned(OnWork) then
 189                 OnWork(Sender, AWorkMode, AWorkCount, Number);
 190 end;
 191
 192 procedure TThreadControl.DownloadEnd(Sender: TObject; Item: TDownloadItem);
 193 begin
 194         if Assigned(OnDownloadEnd) then
 195                 OnDownloadEnd(Sender, Item);
 196 end;
 197
 198 procedure TThreadControl.DownloadMsg(Sender: TObject; Item: TDownloadItem; Msg: string; Icon: TGikoMessageIcon);
 199 begin
 200         if Assigned(OnDownloadMsg) then
 201                 OnDownloadMsg(Sender, Item, Msg, Icon);
 202 end;
 203
 204 end.