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);
  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         for i := 0 to FThreadList.Count - 1 do begin
  60                 TDownloadThread(FThreadList[i]).Free;
  61         end;
  62     FThreadList.Capacity := FThreadList.Count;
  63         FThreadList.Free;
  64     FItemList.Clear;
  65         FItemList.Free;
  66         inherited;
  67 end;
  68
  69 procedure TThreadControl.AddItem(Item: TDownloadItem);
  70 begin
  71         FItemList.Add(Item);
  72 end;
  73
  74 procedure TThreadControl.Execute;
  75 var
  76         List: TList;
  77         i: Integer;
  78         FDownThread: TDownloadThread;
  79 begin
  80         while not Terminated do begin
  81                 Sleep(10);
  82                 List := FItemList.LockList;
  83                 try
  84                         if List.Count > 0 then begin
  85                                 FDownThread := GetSuspendThread;
  86                                 if FDownThread <> nil then begin
  87                                         FDownThread.Item := TDownloadItem(List.Items[0]);
  88                                         List.Delete(0);
  89                                         FDownThread.Resume;
  90                                 end;
  91                         end;
  92                 finally
  93                         FItemList.UnlockList;
  94                 end;
  95                 if FAbort then begin
  96                         for i := 0 to FThreadList.Count - 1 do begin
  97                                 if not TDownloadThread(FThreadList[i]).Suspended then
  98                                         TDownloadThread(FThreadList[i]).Abort;
  99                         end;
 100                         List := FItemList.LockList;
 101                         try
 102                                 List.Clear;
 103                         finally
 104                                 FItemList.UnlockList;
 105                         end;
 106                         FAbort := False;
 107                 end;
 108         end;
 109         for i := 0 to FThreadList.Count - 1 do begin
 110                 TDownloadThread(FThreadList[i]).Terminate;
 111                 if TDownloadThread(FThreadList[i]).Suspended then
 112                         TDownloadThread(FThreadList[i]).Resume;
 113         end;
 114
 115 end;
 116
 117 function TThreadControl.GetSuspendThread: TDownloadThread;
 118 var
 119         i: Integer;
 120         DownloadThread: TDownloadThread;
 121 begin
 122         Result := nil;
 123         if GetActiveThreadCount >= FMaxThreadCount then Exit;
 124         for i := 0 to FThreadList.Count - 1 do begin
 125                 if TDownloadThread(FThreadList[i]).Suspended then begin
 126                         Result := TDownloadThread(FThreadList[i]);
 127                         Break;
 128                 end;
 129         end;
 130         if (Result = nil) and (FMaxThreadCount > FThreadList.Count) then begin
 131                 DownloadThread := TDownloadThread.Create(True);
 132                 DownloadThread.FreeOnTerminate := False;
 133                 DownloadThread.Number := FThreadList.Count;
 134                 DownloadThread.OnWorkBegin := WorkBegin;
 135                 DownloadThread.OnWorkEnd := WorkEnd;
 136                 DownloadThread.OnWork := Work;
 137                 DownloadThread.OnDownloadEnd := DownloadEnd;
 138                 DownloadThread.OnDownloadMsg := DownloadMsg;
 139                 FThreadList.Add(DownloadThread);
 140                 Result := DownloadThread;
 141         end;
 142 end;
 143
 144 function TThreadControl.GetActiveThreadCount: Integer;
 145 var
 146         i: Integer;
 147 begin
 148         Result := 0;
 149         for i := 0 to FThreadList.Count - 1 do begin
 150                 if not TDownloadThread(FThreadList[i]).Suspended then
 151                         Inc(Result);
 152         end;
 153 end;
 154
 155 procedure TThreadControl.DownloadAbort;
 156 begin
 157         FAbort := True;
 158 end;
 159
 160 procedure TThreadControl.SetMaxThreadCount(Count: Integer);
 161 begin
 162         if FMaxThreadCount = Count then Exit;
 163         if Count <= 0 then Count := 1;
 164         if Count > 10 then Count := 10;
 165         FMaxThreadCount := Count;
 166 end;
 167
 168 procedure TThreadControl.WorkBegin(Sender: TObject; AWorkMode: TWorkMode; const AWorkCountMax: Integer; Number: Integer);
 169 begin
 170         if Assigned(OnWorkBegin) then
 171                 OnWorkBegin(Sender, AWorkMode, AWorkCountMax, Number);
 172 end;
 173
 174 procedure TThreadControl.WorkEnd(Sender: TObject; AWorkMode: TWorkMode; Number: Integer);
 175 begin
 176         if Assigned(OnWorkEnd) then
 177                 OnWorkEnd(Sender, AWorkMode, Number);
 178 end;
 179
 180 procedure TThreadControl.Work(Sender: TObject; AWorkMode: TWorkMode; const AWorkCount: Integer; Number: Integer);
 181 begin
 182         if Assigned(OnWork) then
 183                 OnWork(Sender, AWorkMode, AWorkCount, Number);
 184 end;
 185
 186 procedure TThreadControl.DownloadEnd(Sender: TObject; Item: TDownloadItem);
 187 begin
 188         if Assigned(OnDownloadEnd) then
 189                 OnDownloadEnd(Sender, Item);
 190 end;
 191
 192 procedure TThreadControl.DownloadMsg(Sender: TObject; Item: TDownloadItem; Msg: string; Icon: TGikoMessageIcon);
 193 begin
 194         if Assigned(OnDownloadMsg) then
 195                 OnDownloadMsg(Sender, Item, Msg, Icon);
 196 end;
 197
 198 end.