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         for i := 0 to FThreadList.Count - 1 do begin
 112                 TDownloadThread(FThreadList[i]).Terminate;
 113                 if TDownloadThread(FThreadList[i]).Suspended then
 114                         TDownloadThread(FThreadList[i]).Resume;
 115         end;
 116
 117 end;
 118
 119 function TThreadControl.GetSuspendThread: TDownloadThread;
 120 var
 121         i: Integer;
 122         DownloadThread: TDownloadThread;
 123 begin
 124         Result := nil;
 125         if GetActiveThreadCount >= FMaxThreadCount then Exit;
 126         for i := 0 to FThreadList.Count - 1 do begin
 127                 if TDownloadThread(FThreadList[i]).Suspended then begin
 128                         Result := TDownloadThread(FThreadList[i]);
 129                         Break;
 130                 end;
 131         end;
 132         if (Result = nil) and (FMaxThreadCount > FThreadList.Count) then begin
 133                 DownloadThread := TDownloadThread.Create(True);
 134                 DownloadThread.FreeOnTerminate := False;
 135                 DownloadThread.Number := FThreadList.Count;
 136                 DownloadThread.OnWorkBegin := WorkBegin;
 137                 DownloadThread.OnWorkEnd := WorkEnd;
 138                 DownloadThread.OnWork := Work;
 139                 DownloadThread.OnDownloadEnd := DownloadEnd;
 140                 DownloadThread.OnDownloadMsg := DownloadMsg;
 141                 FThreadList.Add(DownloadThread);
 142                 Result := DownloadThread;
 143         end;
 144 end;
 145
 146 function TThreadControl.GetActiveThreadCount: Integer;
 147 var
 148         i: Integer;
 149 begin
 150         Result := 0;
 151         for i := 0 to FThreadList.Count - 1 do begin
 152                 if not TDownloadThread(FThreadList[i]).Suspended then
 153                         Inc(Result);
 154         end;
 155 end;
 156
 157 procedure TThreadControl.DownloadAbort;
 158 begin
 159         FAbort := True;
 160 end;
 161
 162 procedure TThreadControl.SetMaxThreadCount(Count: Integer);
 163 begin
 164         if FMaxThreadCount = Count then Exit;
 165         if Count <= 0 then Count := 1;
 166         if Count > 10 then Count := 10;
 167         FMaxThreadCount := Count;
 168 end;
 169
 170 procedure TThreadControl.WorkBegin(Sender: TObject; AWorkMode: TWorkMode; const AWorkCountMax: Integer; Number: Integer; const AWorkTitle: string);
 171 begin
 172         if Assigned(OnWorkBegin) then
 173                 OnWorkBegin(Sender, AWorkMode, AWorkCountMax, Number, AWorkTitle);
 174 end;
 175
 176 procedure TThreadControl.WorkEnd(Sender: TObject; AWorkMode: TWorkMode; Number: Integer);
 177 begin
 178         if Assigned(OnWorkEnd) then
 179                 OnWorkEnd(Sender, AWorkMode, Number);
 180 end;
 181
 182 procedure TThreadControl.Work(Sender: TObject; AWorkMode: TWorkMode; const AWorkCount: Integer; Number: Integer);
 183 begin
 184         if Assigned(OnWork) then
 185                 OnWork(Sender, AWorkMode, AWorkCount, Number);
 186 end;
 187
 188 procedure TThreadControl.DownloadEnd(Sender: TObject; Item: TDownloadItem);
 189 begin
 190         if Assigned(OnDownloadEnd) then
 191                 OnDownloadEnd(Sender, Item);
 192 end;
 193
 194 procedure TThreadControl.DownloadMsg(Sender: TObject; Item: TDownloadItem; Msg: string; Icon: TGikoMessageIcon);
 195 begin
 196         if Assigned(OnDownloadMsg) then
 197                 OnDownloadMsg(Sender, Item, Msg, Icon);
 198 end;
 199
 200 end.