Delphi利用线程池实现基于TIdFTP的FTP分段下载

FTP下载单元,使用TIdFtp实现,利用SIZE命令获取文件大小,使用REST命令分段下载: 

unit rsrFtpDown;

interface
uses SysUtils, Classes, Windows, Messages, Forms, Controls, ComObj, ActiveX,
    IdResourceStrings, IDTCPClient, IdIOHandlerSocket, IdFTP, IdComponent, IdSimpleServer,
    rsrThreadPoolSimple, MATH, StrUtils;

{
自动下载组件
by    renshouren
mail  root@renshou.net
QQ    114032666
2019.10.05

使用的组件
1、TIdFTP  Indy FTP客户端
2、TThreadsPool 线程池

工作原理及流程
调用本单元,将自动在程序初始化时生成线程池TThreadPoolDown实例 Share_ThreadPool_FTPDown
一、外部调用方法
    外部只需要一次性调用  FtpDown() 函数向线程池加入下载任务,下载任务执行中的事件会通过调用时注册的
回调函数 AFtpDownEvent 进行通知。
二、内部工作流程
1、FtpDown()函数将调用TThreadPoolDown.AddFtpDown() ,然后调用TADownFileObj.MakeGetFileSizeObj()分配线程任务
本过程中,将向回调函数 AFtpDownEvent 触发 HEM_ADDURL 事件通知
2、工作线程调用任务对象TFTPHeadObj.DoThreadExecute 过程获取远程文件大小
备注:该功能实际使用到FTP命令SIZE,该命令一些老版本FTP服务器有可能不支持
本过程中,若获取文件大小成功,将向回调函数 AFtpDownEvent 触发 HEM_GETSIZE 事件通知,
若失败,则触发 HEM_ERROR 事件通知
3、得到远程文件大小后,调用TADownFileObj.MakeGetObjs(),分配获取远程文件线程任务
本过程中,开始时,将向回调函数 AFtpDownEvent 触发 HEM_WORKBEGIN 事件通知
在接收数据时,向回调函数  AFtpDownEvent 触发 HEM_WORK 事件通知
4、工作线程调用任务对象 TFTPGetObj.DoThreadExecute 实际下载远程文件数据块
每一个数据块下载任务完成后,触发 HEM_BLOCKOK 事件通知
5、所有数据块完成后,将调用 DoDownloadOK 函数,触发 HEM_DOWNOK 事件通知

}

Const
  //一个下载块,目标文件大于此,则进行分块下载(可以通过设置TADownFileObj.ADefBlockSize 重新指定)
  DefBlockSize = 1024*1024*1;

  ErrMsg_BlockDownloaded  ='块下载完成。';
  ErrMsg_OtherBlockHasError ='因发生错误而取消:';
  ErrMsg_FileNotExists  ='远程文件不存在。';

type
  TADownFileObj = class;
  TFTPGetObj = class;
  TDownThread = class;

  TFTPEventMode  =(
    HEM_ADDURL, HEM_GETSIZE, HEM_WORK, HEM_DOWNOK,  HEM_BLOCKOK,
    HEM_SPEED, HEM_WORKBEGIN, HEM_ERROR);

  TFTPDownEvent  = procedure (Sender: TObject; ADownFileObj: TADownFileObj; EventMode: TFTPEventMode; ErrorMsg:string) of object;


  TDownServerInfo = record
     FHost  :string;
     FPort  :Integer;
     FUserName  :string;
     FPassWord  :string;
     FRemoteFile  :string;//文件相对URL
  end;

  TRSRIdFTP = class (TIdFTP)
  protected
    procedure ResumeGet(const ASourceFile: string; ADest: TStream; APosition: Integer);
  public
  end;


  //一个需要下载的 文件
  TADownFileObj  = class
  private
    FStream :TMemoryStream;

    //----------用于计算下载速度,临时变量,每隔3秒做一次计算
    FTmpRefreshTick :LongWord;
    FTmpRefreshSize :LongWord;

    //生成下载任务
    procedure MakeGetObjs;
    //采取 Head 方式获取文件信息
    procedure MakeGetFileSizeObj;

    procedure FtpGetWork(AFtpGetObj: TFTPGetObj; const AWorkCount: Integer);

  protected
    AUrl  :String;
    ASavePath :String;

    FHasError  :Boolean;//是否已发生错误
    FLastErrMsg :String;

    FileTestOK  :Boolean;//是否已正确获得文件大小

    //需要下载文件的大小
    AFileSize :Int64;
    //已下载大小
    ADownSize :Int64;

    //开始下载时间
    BeginTime :TDateTime;
    BeginTick :LongWord;

    //是否下载已全部完成
    FDownloaded  :Boolean;
    EndTime :TDateTime;
    EndTick :LongWord;

    //分割任务列表
    DownWorkItems :TList;

    //下载任务完成,做一些操作
    procedure DoDownloadOK;virtual;
  public
    //下载过程中的事件通知
    FtpDownEvent :TFTPDownEvent;

    Host  :String;
    Port  :Integer;
    UserName  :String;
    PassWord  :String;


    //用于自定义附加数据
    Data  :Pointer;
    //FTP服务器是否支持断点续传 REST 命令    True=支持 False=不支持
    CanSupportRest  :Boolean;
    ADefBlockSize :Integer;
    Constructor Create; overload;
    Destructor  Destroy; override;

    //从Url中分离出文件名
    function  GetFileNameFromUrl (AUrl:String):String;
    //从Url中分离出完整文件名(包括路径)
    function  GetFullFileNameFromUrl (AUrl:String):String;

    property  Url :String read AUrl write AUrl;
    property  SavePath  :String read ASavePath write ASavePath;
    property  FileSize  :Int64 read AFileSize;
    property  DownSize  :Int64 read ADownSize;
    property  Stream  :TMemoryStream read FStream;
    property  HasError  :Boolean read FHasError;
    property  LastErrMsg  :String read FLastErrMsg;
    property  Downloaded  :Boolean read FDownloaded;
  end;

  //一个获得文件大小任务
  TFTPHeadObj  = class(TWorkItem)
  private
    FErrMsg :String;
    procedure DoThreadError;
  protected
    procedure DoThreadExecute (Sender: TThreadsPool; AThread: TProcessorThread);override;
    procedure DoSync (ThreadsPool:TThreadsPool; AThread: TProcessorThread);override;
  public
    ADownFileObj  :TADownFileObj;
  end;

  //一个下载任务数据块
  TFTPGetObj = class(TWorkItem)
  private
    FStream :TMemoryStream;
    FAWorkCount,
    FCurCount :Integer;
    FDownThread :TDownThread;

    FErrMsg :String;

    procedure OnWork(Sender: TObject; AWorkMode: TWorkMode; const AWorkCount: Integer);
    procedure DoThreadError;
  protected
    procedure DoThreadExecute (Sender: TThreadsPool; AThread: TProcessorThread);override;
    procedure DoSync (ThreadsPool:TThreadsPool; AThread: TProcessorThread);override;
    procedure DoFtpGetWork;

  public
    ADownFileObj  :TADownFileObj;
    //开始位置、结束位置
    AStart, AEnd  :LongWord;
    //已下载数据量
    RecvCount :LongWord;
    BlockNo :Integer;
    BlockOK  :Boolean;

    Constructor Create; overload;
    Destructor  Destroy; override;
  end;


  //工作线程(下载)
  TDownThread = class (TProcessorThread)
  private
    FFtp :TRsrIdFTP;
    FMakeTick :LongWord;
    FLastRunOKTick  :LongWord;
    FErrorMsg: String;

    procedure DoThreadError;
    procedure DoSyncExec;
  protected

    procedure DoInit; override;
    procedure DoFInit; override;
    procedure DoWork;virtual;
  public
    constructor Create(APool: TThreadsPool);override;
  end;

  {
  FTP 下载线程池管理类
  }
  TThreadPoolDown = class (TThreadsPool)
  private
    FCallBackEvent  :TFTPDownEvent;

    //下载任务列表
    FDownFileObjs :TList;
    procedure   ClearDownFileObjs;
  protected
    //线程执行代码-》执行任务
    procedure   DoProcessRequest(aDataObj: TWorkItem; aThread: TProcessorThread);override;
  public
    constructor Create(AOwner: TComponent); override;
    Destructor  Destroy; override;

    //增加下载任务
    procedure    AddFtpDown (
      ASavePath  :String;
      AUrl  :String;
      AHost:String; AUserName:String='Anonymous'; APassWord:String='114032666@qq.com'; APort:Integer=21;
      AFtpDownEvent :TFTPDownEvent=nil;AMaxBlockSize: Integer=DefBlockSize);overload;
    procedure   AddFtpDown (ADownFileObj  :TADownFileObj);overload;
  end;



  {
  函数名:FtpDown
  作用:下载FTP服务器上的文件
  参数:
  ASavePath ->本地保存路径,本参数不为空,则在下载完成后,自动保存到该路径下。
     如:
     ASavePath='C:\Download'
     AUrl='/soft/MyFile.rar'
     则表示在下载完成后,保存为本地文件 C:\Download\MyFile.rar
  AUrl  ->下载任务Url地址
  AHost ->FTP服务器地址,如:jinlifangzhi.cn
  AUserName ->FTP服务器帐号,如:Anonymous
  APassWord ->FTP服务器密码,如:114032666@qq.com
  APort ->FTP服务器端口,默认:21
  AFtpDownEvent ->下载过程中产生的事件通知
  }

  procedure FtpDown (ASavePath  :String;
      AUrl  :String;
      AHost:String; AUserName:String='Anonymous'; APassWord:String='114032666@qq.com'; APort:Integer=21;
      AFtpDownEvent :TFTPDownEvent=nil;AMaxBlockSize: Integer=DefBlockSize);overload;

  procedure FtpDown (ADownFileObj:TADownFileObj);overload;

  function GetDownServerInfo(const URL: string;
  var DSInfo: TDownServerInfo):Boolean;

var
  Share_ThreadPool_FTPDown  :TThreadPoolDown;

implementation


procedure FtpDown (ASavePath  :String;
      AUrl  :String;
      AHost:String; AUserName:String; APassWord:String; APort:Integer;
      AFtpDownEvent :TFTPDownEvent;
      AMaxBlockSize: Integer);

begin

  Share_ThreadPool_FTPDown.AddFtpDown(ASavePath, AUrl, AHost, AUserName, APassWord, APort, AFtpDownEvent, AMaxBlockSize);


end;

procedure FtpDown (ADownFileObj:TADownFileObj);
begin
  Share_ThreadPool_FTPDown.AddFtpDown (ADownFileObj);
end;


function GetDownServerInfo(const URL: string;
  var DSInfo: TDownServerInfo):Boolean;
var s, shost, suser, spwd, sport: string;
    n, n2: integer;
begin
   result := False;
   //URL 必须是形如 ftp://xxx.xxx.net/xxx的完整格式
   //ftp://账号:密码@IP地址:端口号
   DSInfo.FRemoteFile := '/';
   s  := Trim (URL);
   if Pos ('FTP://', UpperCase (s)) <> 1 then
   begin
     exit;
   end;
   delete (s, 1, 6);

   shost  := s;
   n  := pos ('/', shost);   //第一个/前面为host
   if n > 0 then begin
      DSInfo.FRemoteFile  := copy (shost, n , length (shost) - n + 1);
      delete (shost, n, length (shost) - n + 1);
   end;

   suser  := 'Anonymous';
   spwd := 'root@renshou.net';
   n  := pos ('@', shost);
   if n > 0 then begin
      n2  := pos (':', shost);
      if (n2 > 0) and (n2 < n) then begin
         suser := copy (shost, 1, n2 - 1);
         spwd := copy (shost, n2 + 1, n - n2 - 1);
      end;
      delete (shost, 1, n);
   end;

   sport  := '21';
   n  := pos (':', shost);
   if n > 0 then begin
      sport := copy (shost, n + 1, length (shost) - n);
      delete (shost, n, length (shost) - n + 1);
   end;

   DSInfo.FHost := shost;
   DSInfo.FPort := StrToIntDef (sport, 21);
   DSInfo.FUserName := suser;
   DSInfo.FPassWord := spwd;

   result := True;
end;





{ TADownFileObj }

constructor TADownFileObj.Create;
begin
  self.FStream  := TMemoryStream.Create;
  DownWorkItems := TList.Create;
  self.CanSupportRest := True;
  self.ADefBlockSize  := DefBlockSize;
end;

destructor TADownFileObj.Destroy;
begin
  FreeAndNil (DownWorkItems);
  FreeAndNil (self.FStream);
  inherited;
end;

procedure TADownFileObj.DoDownloadOK;
begin
  //文件下载已完成
  //FStream.SaveToFile('C:\tmp\test.rar');
  self.FDownloaded  := True;
  if self.ASavePath<>'' then
    FStream.SaveToFile(self.ASavePath);
  if Assigned(self.FtpDownEvent) then
    self.FtpDownEvent(FStream, self, HEM_DOWNOK, '');
end;

function TADownFileObj.GetFileNameFromUrl(AUrl: String): String;
var slist: TStringList;
begin
  slist := TStringList.Create;
  try
    slist.Delimiter := '/';
    slist.DelimitedText := AUrl;
    if slist.Count>0 then
      result  := slist[slist.count-1]
    else
      result  := AUrl;
  finally

  end;
end;

function TADownFileObj.GetFullFileNameFromUrl(AUrl: String): String;
begin
  result  := AnsiReplaceText (AUrl, '/', '\');
end;

procedure TADownFileObj.FtpGetWork(AFtpGetObj: TFTPGetObj; const AWorkCount: Integer);
var AStr:String;
    dbl:Double;
begin
  self.ADownSize  := self.ADownSize+AWorkCount;

  if self.FTmpRefreshTick+1000<GetTickCount() then
  begin
    if Assigned (self.FtpDownEvent) then begin
      //每秒bytes
      dbl := (self.ADownSize-self.FTmpRefreshSize)/(GetTickCount-self.FTmpRefreshTick)*1000;
      if dbl>1024*1024 then
      begin
        AStr  := Format ('%.02fM', [dbl/(1024*1024)]);
      end else begin
        AStr  := Format ('%.02fK', [dbl/1024]);
      end;
      self.FtpDownEvent(AFtpGetObj, self, HEM_SPEED, AStr);
    end;

    self.FTmpRefreshTick  := GetTickCount();
    self.FTmpRefreshSize  := self.ADownSize;
  end;

  if Assigned (self.FtpDownEvent) then begin
    self.FtpDownEvent(AFtpGetObj, self, HEM_WORK, IntToStr(AWorkCount));
  end;
end;

procedure TADownFileObj.MakeGetFileSizeObj;
var aFtpHeadObj  :TFTPHeadObj;
begin
  aFtpHeadObj := TFTPHeadObj.Create;
  aFtpHeadObj.ADownFileObj  := self;
  Share_ThreadPool_FTPDown.AddRequest(aFtpHeadObj);
end;

procedure TADownFileObj.MakeGetObjs;
var aGetObj: TFTPGetObj;
    aPos: LongWord;
    n: Integer;
begin
  if FileTestOK then
  begin
    self.BeginTime  :=Now();
    self.BeginTick  := GetTickCount();
    self.EndTime  := 0;
    self.EndTick  := 0;
    self.ADownSize  := 0;

    self.FTmpRefreshTick  := GetTickCount();
    self.FTmpRefreshSize  := 0;

    if Assigned (self.FtpDownEvent) then
      self.FtpDownEvent(self, self, HEM_WORKBEGIN, '');

    //服务器不支持续传或远程文件小于指定大小,则通过单个线程完成
    if (not CanSupportRest) or (AFileSize<=ADefBlockSize) then
    begin
      aGetObj := TFTPGetObj.Create;
      aGetObj.ADownFileObj  := self;
      aGetObj.AStart  := 0;
      aGetObj.AEnd  := AFileSize-1;
      self.DownWorkItems.Add(aGetObj);
      Share_ThreadPool_FTPDown.AddRequest(aGetObj);
      exit;
    end;

    //否则,按文件大小生成线程任务
    aPos  := 0;
    n := 0;
    While aPos<AFileSize do begin
      Inc (n);
      aGetObj := TFTPGetObj.Create;
      aGetObj.ADownFileObj  := self;
      aGetObj.AStart  := aPos;
      aGetObj.AEnd  := Min(aPos+ADefBlockSize-1, AFileSize-1);
      aGetObj.BlockNo := n;
      aPos  := aGetObj.AEnd + 1;
      self.DownWorkItems.Add(aGetObj);
      Share_ThreadPool_FTPDown.AddRequest(aGetObj);
    end;
  end;
end;

{ TDownThread }

constructor TDownThread.Create(APool: TThreadsPool);
begin
  inherited;

end;

procedure TDownThread.DoFInit;
begin
  FreeAndNil (self.FFtp);
  CoUninitialize;
  inherited;

end;

procedure TDownThread.DoInit;
begin
  inherited;
  CoInitialize(nil);
  FFtp := TRsrIdFtp.Create(nil);
end;

procedure TDownThread.DoSyncExec;
begin

end;

procedure TDownThread.DoThreadError;
begin

end;

procedure TDownThread.DoWork;
begin

end;

{ TThreadPoolDown }

procedure TThreadPoolDown.AddFtpDown(ASavePath  :String;
      AUrl  :String;
      AHost:String; AUserName:String; APassWord:String; APort:Integer;
      AFtpDownEvent :TFTPDownEvent;
      AMaxBlockSize: Integer);
var ADownFileObj  :TADownFileObj;
begin
  ADownFileObj  := TADownFileObj.Create;
  ADownFileObj.AUrl := AUrl;
  ADownFileObj.ASavePath  := ASavePath;
  ADownFileObj.Host := AHost;
  ADownFileObj.UserName := AUserName;
  ADownFileObj.PassWord := APassWord;
  ADownFileObj.Port := APort;
  ADownFileObj.FtpDownEvent  := AFtpDownEvent;
  ADownFileObj.ADefBlockSize  := AMaxBlockSize;
  AddFtpDown (ADownFileObj);
end;

procedure TThreadPoolDown.AddFtpDown(ADownFileObj: TADownFileObj);
begin
  Share_ThreadPool_FTPDown.FDownFileObjs.Add(ADownFileObj);
  if Assigned (ADownFileObj.FtpDownEvent) then
    ADownFileObj.FtpDownEvent(self, ADownFileObj, HEM_ADDURL, ADownFileObj.AUrl);
  ADownFileObj.MakeGetFileSizeObj;
end;

procedure TThreadPoolDown.ClearDownFileObjs;
var I:Integer;
    o:TADownFileObj;
begin
  for I := 0 to self.FDownFileObjs.Count - 1 do
  begin
    o := TADownFileObj(FDownFileObjs.Items[I]);
    FreeAndNil (o);
  end;
  self.FDownFileObjs.Clear;
end;

constructor TThreadPoolDown.Create(AOwner: TComponent);
begin
  inherited;
  FDownFileObjs := TList.Create;
end;

destructor TThreadPoolDown.Destroy;
begin
  self.ClearDownFileObjs;
  FreeAndNil (FDownFileObjs);
  inherited;
end;

procedure TThreadPoolDown.DoProcessRequest(aDataObj: TWorkItem;
  aThread: TProcessorThread);
begin
  inherited;

end;

{ TFTPHeadObj }

procedure TFTPHeadObj.DoSync(ThreadsPool: TThreadsPool;
  AThread: TProcessorThread);
begin
  if self.ADownFileObj.FileTestOK then
  begin
    self.ADownFileObj.FStream.Size  := self.ADownFileObj.AFileSize;
    self.ADownFileObj.AFileSize := self.ADownFileObj.AFileSize;

    if Assigned (self.ADownFileObj.FtpDownEvent) then
      self.ADownFileObj.FtpDownEvent(self, self.ADownFileObj, HEM_GETSIZE, '');

    self.ADownFileObj.MakeGetObjs;
  end;
  inherited;
end;

procedure TFTPHeadObj.DoThreadError;
begin
  self.ADownFileObj.FHasError := True;
  self.ADownFileObj.FLastErrMsg := FErrMsg;
  
  if Assigned (self.ADownFileObj.FtpDownEvent) then
    self.ADownFileObj.FtpDownEvent(self, self.ADownFileObj, HEM_ERROR, FErrMsg);
end;

procedure TFTPHeadObj.DoThreadExecute(Sender: TThreadsPool;
  AThread: TProcessorThread);
var tr: TDownThread;
    AStr, tmpUrl:String;
begin
  self.ADownFileObj.FileTestOK  := False;
  tr  := TDownThread (AThread);

  try
    With tr do begin
         FFTP.ReadTimeout  := 5000;
         FFTP.Host  := self.ADownFileObj.Host;
         FFTP.Port  := self.ADownFileObj.Port;
         FFTP.Username  := self.ADownFileObj.UserName;
         FFTP.Password  := self.ADownFileObj.PassWord;

         FFTP.Disconnect;
         FFTP.Connect();

         //if Pos('/', self.ADownFileObj.AUrl)>0 then
         //  FFTP.ChangeDir('金利纺织');
         self.ADownFileObj.AFileSize := FFTP.Size(self.ADownFileObj.AUrl);
         if self.ADownFileObj.AFileSize>=0 then
           self.ADownFileObj.FileTestOK := True
         else
         begin
           FErrMsg  := ErrMsg_FileNotExists;
           tr.Synchronize(self.DoThreadError);
         end;
    end;

  except on E:Exception do
    begin
      FErrMsg := E.Message;
      tr.Synchronize(self.DoThreadError);
    end;
  end;

  inherited;

end;

{ TFTPGetObj }

constructor TFTPGetObj.Create;
begin
  self.FStream  := TMemoryStream.Create;
end;

destructor TFTPGetObj.Destroy;
begin
  FreeAndNil (self.FStream);
  inherited;
end;

procedure TFTPGetObj.DoFtpGetWork;
var tmpCount: Integer;
begin
  self.ADownFileObj.FtpGetWork(self, self.FCurCount);
end;

procedure TFTPGetObj.DoSync(ThreadsPool: TThreadsPool;
  AThread: TProcessorThread);
var I: Integer;
    aFtpGetObj: TFTPGetObj;
    FileDownOK  :Boolean;
    th, th2: LongWord;
    pid: LongWord;
begin
  if self.BlockOK then
  begin
    self.ADownFileObj.FStream.Position  := self.AStart;
    //调试时查看分割数据包是否完整
    //self.FStream.SaveToFile(Format('D:\%X_%X.mem', [self.AStart, self.AEnd]));
    self.ADownFileObj.FStream.Write(PChar(TMemoryStream(self.FStream).Memory)^, self.AEnd-self.AStart+1);
    FreeAndNil (self.FStream);
    if Assigned (self.ADownFileObj.FtpDownEvent) then
      self.ADownFileObj.FtpDownEvent(self, self.ADownFileObj, HEM_BLOCKOK, '');
  end;

  FileDownOK  := True;
  for I := 0 to self.ADownFileObj.DownWorkItems.Count - 1 do
  begin
    aFtpGetObj := TFTPGetObj(self.ADownFileObj.DownWorkItems.Items[I]);
    if not aFtpGetObj.BlockOK then
    begin
      FileDownOK  := False;
      break;
    end;
  end;


  if FileDownOK then
  begin
    self.ADownFileObj.DoDownloadOK;
  end;
  inherited;

end;

procedure TFTPGetObj.DoThreadError;
begin
  self.ADownFileObj.FHasError  := True;
  self.ADownFileObj.FLastErrMsg  := self.FErrMsg;

  if Assigned (self.ADownFileObj.FtpDownEvent) then
    self.ADownFileObj.FtpDownEvent(self, self.ADownFileObj, HEM_ERROR, FErrMsg);
end;

procedure TFTPGetObj.DoThreadExecute(Sender: TThreadsPool;
  AThread: TProcessorThread);
var tr: TDownThread;
    AStr:String;
begin

  self.FDownThread  := TDownThread(AThread);

  tr  := TDownThread (AThread);

  try

    self.BlockOK := False;

    tr.FFtp.Disconnect;

    tr.FFTP.ReadTimeout  := 5000;
    tr.FFTP.Host  := self.ADownFileObj.Host;
    tr.FFTP.Port  := self.ADownFileObj.Port;
    tr.FFTP.Username  := self.ADownFileObj.UserName;
    tr.FFTP.Password  := self.ADownFileObj.PassWord;

    tr.FFtp.OnWork := self.OnWork;
    tr.FFtp.Passive := True;
    tr.FFtp.Connect();
    tr.FFTP.ResumeGet(self.ADownFileObj.AUrl, FStream, AStart);

    self.BlockOK := True;
  except on E:Exception do
    begin
      FErrMsg := E.Message;
      if E.Message=ErrMsg_OtherBlockHasError then
      begin
        //因其他下载线程发生错误
      end else
      if E.Message=ErrMsg_BlockDownloaded then
      begin
        self.BlockOK := True;
      end else
        tr.Synchronize(self.DoThreadError);
    end;

  end;


  inherited;
end;

procedure TFTPGetObj.OnWork(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCount: Integer);
var tmpI: Integer;
begin
  if self.ADownFileObj.FHasError then begin
    Raise Exception.Create(ErrMsg_OtherBlockHasError);
    exit;
  end;

  tmpI  := MIN (AEnd-AStart+1, AWorkCount);
  self.FCurCount  := tmpI-self.FAWorkCount;
  self.FAWorkCount  := tmpI;
  self.FDownThread.Synchronize(self.DoFtpGetWork);

  //已完成本下载块指定大小,则不管是否RETR命令是否完成,均作为任务完成
  if FStream.Size>=AEnd-AStart+1 then
  begin
    self.BlockOK := True;
    //self.FDownThread.FFtp.Disconnect;
    Raise Exception.Create(ErrMsg_BlockDownloaded);
  end;
end;

{ TRSRIdFTP }

procedure TRSRIdFTP.ResumeGet(const ASourceFile: string; ADest: TStream;
  APosition: Integer);
var
  LIP: string;
  LPort: Integer;
  LResponse: Integer;
begin
  DoStatus(ftpTransfer, [RSFTPStatusStartTransfer]); try
    if FPassive then begin
      SendPassive(LIP, LPort);
      FDataChannel := TIdTCPClient.Create(nil); try
        with (FDataChannel as TIdTCPClient) do begin
          if (Self.IOHandler is TIdIOHandlerSocket) then begin
            if not assigned(IOHandler) then begin
              IOHandler:=TIdIOHandlerSocket.create(nil);
            end;
            TIdIOHandlerSocket(IOHandler).SocksInfo.Assign(TIdIOHandlerSocket(Self.IOHandler).SocksInfo);
            TIdIOHandlerSocket(IOHandler).SocksInfo.IOHandler:=IOHandler;
          end;
          InitDataChannel;
          Host := LIP;
          Port := LPort;
          Connect; try
            //2019.10.07 定位续传位置
            if APosition>0 then
            begin
              Self.SendCmd('REST ' + IntToStr(APosition), [350]);   {Do not tranlsate}
            end;

            Self.WriteLn('RETR ' + ASourceFile);
            Self.GetResponse([125, 150, 154]); //APR: Ericsson Switch FTP
            ReadStream(ADest, -1, True);
          finally Disconnect; end;
        end;
      finally FDataChannel.IOHandler.free; FDataChannel.IOHandler:=nil; FreeAndNil(FDataChannel); end;
    end else begin
      FDataChannel := TIdSimpleServer.Create(nil); try
        with TIdSimpleServer(FDataChannel) do begin
          InitDataChannel;
          BoundIP := (Self.IOHandler as TIdIOHandlerSocket).Binding.IP;
          BoundPort := Self.DataPort;
          BoundPortMin := Self.DataPortMin;
          BoundPortMax := Self.DataPortMax;
          BeginListen;
          SendPort(Binding);

          //2019.10.07 定位续传位置
          if APosition>0 then begin
            Self.SendCmd('REST ' + IntToStr(APosition), [350]);  {Do not translate}
          end;
          Self.SendCmd('RETR '+ASourceFile, [125, 150, 154]); //APR: Ericsson Switch FTP
          Listen;
          ReadStream(ADest, -1, True);
        end;
      finally
        FreeAndNil(FDataChannel);
      end;
    end;
  finally
    DoStatus(ftpReady, [RSFTPStatusDoneTransfer]);
  end;
  // ToDo: Change that to properly handle response code (not just success or except)
  // 226 = download successful, 225 = Abort successful}
  LResponse := GetResponse([225, 226, 250, 426, 450]);
  if (LResponse = 426) or (LResponse = 450) then begin
    GetResponse([226, 225]);
    DoStatus(ftpAborted, [RSFTPStatusAbortTransfer]);
  end;
end;

initialization
  Share_ThreadPool_FTPDown  := TThreadPoolDown.Create(nil);
  Share_ThreadPool_FTPDown.ProcessorThreadClass  := TDownThread;
  Share_ThreadPool_FTPDown.ThreadsMin  := 5;
  Share_ThreadPool_FTPDown.ThreadsMax  := 10;
finalization
  FreeAndNil (Share_ThreadPool_FTPDown);

end.

 

 

线程池单元:

unit rsrThreadPoolSimple;

{
线程池单元
by renshouren
创建日期:2019.10.18
}

interface
uses
  Windows, Classes, Messages, Forms;

type

  TThreadsPool = class;
  TProcessorThread  = class;
  TProcessorThreadClass = class of TProcessorThread;

  // 储存请求数据的基本类
  TWorkItem = class(TObject)
  private
    FOnThreadExecute:TNotifyEvent;
    FTmpThread: TProcessorThread;
    FTmpThreadsPool  :TThreadsPool;
  protected
    procedure _DoSync;virtual;
  public
    //在线程中执行的代码
    procedure DoThreadExecute (Sender: TThreadsPool; AThread: TProcessorThread);virtual;

    //在主线程中执行的代码
    procedure DoSync (ThreadsPool:TThreadsPool; AThread: TProcessorThread);virtual;
  end;

  // 工作线程仅用于线程池内, 不要直接创建并调用它。
  TProcessorThread = class(TThread)
  private
    procedure DoThreadExit();
    procedure DoGetRequest();
  protected

    FPool: TThreadsPool;
    // 当前处理的数据对像。
    FProcessingDataObject: TWorkItem;
    procedure DoFreeWorkItem();virtual;

    procedure Execute; override;


    //线程自身初始化
    procedure DoInit;virtual;
    procedure DoFInit; virtual;
  public
    constructor Create(APool: TThreadsPool);virtual;
    destructor Destroy; override;
  end;


  TThreadsPool = class(TComponent)
  private
    FProcessorThreadClass  :TProcessorThreadClass;
    FQueue: TList;

    // 工作中的线程
    FThreads: TList;

    // 最少, 最大线程数
    FThreadsMax: Integer;
    // 最少, 最大线程数
    FThreadsMin: Integer;

    //工作任务信号灯
    hSemRequestCount,
    //线程池已退出信号灯
    hSemPoolExit  :THandle;

    //检查现有线程是否已达到上限,如果未达到,则创建新线程
    procedure CheckThreadCount();


  protected

    //在线程中执行的代码
    procedure DoProcessRequest(aDataObj: TWorkItem; aThread: TProcessorThread);
      virtual;

    // 申请任务
    function GetRequest(out Request: TWorkItem):Boolean;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    // 就进行任务是否重复的检查, 检查发现重复就返回 False
    function AddRequest(aDataObject: TWorkItem): Boolean;

    property ProcessorThreadClass :TProcessorThreadClass read FProcessorThreadClass write FProcessorThreadClass;
  published
    // 最大线程数
    property ThreadsMax: Integer read FThreadsMax write FThreadsMax default 5;
    // 最小线程数
    property ThreadsMin: Integer read FThreadsMin write FThreadsMin default 0;
  end;


implementation
uses
  SysUtils;

// 储存请求数据的基本类
{
********************************** TWorkItem ***********************************
}

procedure TWorkItem.DoSync(ThreadsPool: TThreadsPool;
  AThread: TProcessorThread);
begin

end;

procedure TWorkItem.DoThreadExecute(Sender: TThreadsPool;
  AThread: TProcessorThread);
begin
  if Assigned (FOnThreadExecute) then
    FOnThreadExecute (self);
  self.FTmpThreadsPool  := Sender;
  self.FTmpThread := AThread;
  AThread.Synchronize(self._DoSync);
end;


procedure TWorkItem._DoSync;
begin
  DoSync (self.FTmpThreadsPool, self.FTmpThread);
end;

{ TWorkItem.TextForLog }

{
********************************* TThreadsPool *********************************
}

procedure TThreadsPool.CheckThreadCount;
var th:TThread;
begin
  if self.FThreads.Count<self.FThreadsMax then
  begin
    th  := self.FProcessorThreadClass.Create(self);
    FThreads.Add( th);
    th.Resume;
  end;
end;

constructor TThreadsPool.Create(AOwner: TComponent);
var
  DueTo: Int64;
begin

  inherited;

  self.FProcessorThreadClass  := TProcessorThread;

  FQueue := TList.Create;

  FThreads := TList.Create;

  FThreadsMin := 0;
  FThreadsMax := 2;

  //工作任务信号灯
  hSemRequestCount := CreateSemaphore(nil, 0, $7FFFFFFF, nil);

  //线程池管理类信号灯
  hSemPoolExit  :=  CreateSemaphore(nil, 0, $7FFFFFFF, nil);

end; { TThreadsPool.Create }

destructor TThreadsPool.Destroy;
var
  n, i: Integer;
  Handles: array of THandle;
begin
  if FThreads.Count>0 then
    Windows.ReleaseSemaphore(self.hSemPoolExit, 1, nil);
  While FThreads.Count>0 do
  begin
    Application.ProcessMessages;
  end;

  FThreads.Free;

  for i := FQueue.Count - 1 downto 0 do
    TWorkItem(FQueue[i]).Free;
  FQueue.Free;


  CloseHandle(hSemRequestCount);
  CloseHandle(hSemPoolExit);

  inherited;
end; { TThreadsPool.Destroy }

function TThreadsPool.AddRequest(aDataObject: TWorkItem): Boolean;
var
  i: Integer;
begin

  Result := False;

  //将任务加入队列
  FQueue.Add(aDataObject);

  //检查现有线程是否已达到上限,如果未达到,则创建新线程
  CheckThreadCount();

  //释放一个同步信号量
  ReleaseSemaphore(hSemRequestCount, 1, nil);

  Result := True;

end; { TThreadsPool.AddRequest }



procedure TThreadsPool.DoProcessRequest(aDataObj: TWorkItem; aThread:
  TProcessorThread);
begin
  aDataObj.DoThreadExecute(self, aThread);
end; { TThreadsPool.DoProcessRequest }




{
函 数 名:TThreadsPool.GetRequest
功能描述:申请任务
输入参数:out Request: TRequestDataObject
返 回 值: True=>成功;False=>失败
}

function TThreadsPool.GetRequest(out Request: TWorkItem):Boolean;
var I: Integer;
begin
  result  := False;
  Request := nil;
  if self.FQueue.Count>0 then
  begin
    Request := TWorkItem(self.FQueue.Items[0]);
    FQueue.Delete(0);
    result  := True;
  end;

end;

{ TThreadsPool.GetRequest }


// 工作线程仅用于线程池内, 不要直接创建并调用它。
{
******************************* TProcessorThread *******************************
}

constructor TProcessorThread.Create(APool: TThreadsPool);
begin
  inherited Create(True);
  FPool := aPool;
  self.FreeOnTerminate  := True;

end; { TProcessorThread.Create }

destructor TProcessorThread.Destroy;
begin
  inherited;
end;

procedure TProcessorThread.DOFInit;
begin

end;

procedure TProcessorThread.DoFreeWorkItem;
begin
    if Assigned(self.FProcessingDataObject) then
      FreeAndNil (FProcessingDataObject);
end;

procedure TProcessorThread.DoGetRequest;
begin
  FPool.GetRequest(self.FProcessingDataObject);
  
end;

procedure TProcessorThread.DoInit;
begin
end;

procedure TProcessorThread.DoThreadExit;
var index: Integer;
begin
  index :=FPool.FThreads.IndexOf(self);
  if index>=0 then
  begin
    FPool.FThreads.Delete(index);
  end;
  //如果还存在未退出的线程,则继续设置信号,让下一线程退出
  if FPool.FThreads.Count>0 then
    Windows.ReleaseSemaphore(FPool.hSemPoolExit, 1, nil);
end;

procedure TProcessorThread.Execute;
var Handles:array[0..1] of THandle;
    step: Integer;
begin
  step  := 0;
  //工作任务信号
  Handles[0]  := FPool.hSemRequestCount;

  //退出信号
  Handles[1]  := FPool.hSemPoolExit;
  
  try
  step  := 1;
  try
  //执行自身初始化事件
  self.DoInit;

  step  := 2;
  //任务置空
  FProcessingDataObject := nil;

  step  := 3;
  //大循环
  while not Self.Terminated do
  begin
     step := 4;
    //阻塞线程,使线程休眠
    case WaitForMultipleObjects(Length(Handles), @Handles, False, INFINITE) of

      WAIT_OBJECT_0+0:
        begin
          step  := 5;
          //从线程池的任务队列中得到任务
          self.Synchronize(DoGetRequest);
          if FProcessingDataObject<>nil then begin
            try
              step  := 6;
              //执行任务
              FPool.DoProcessRequest(FProcessingDataObject, Self);
            except
              on e: Exception do
            end;

            self.Synchronize(DoFreeWorkItem);
          end;


        end;

      //线程池已退出
      WAIT_OBJECT_0+1:
        begin
          step  := 7;
          break;
        end;
    end;
    sleep(2);
  end;

  step  := 8;
  //
  self.DOFInit;
  step  := 9;
  except on E:Exception do
    begin
      asm
        mov eax, step
      end;
    end;
  end;
  finally
    self.Synchronize(DoThreadExit);
  end;



end; { TProcessorThread.Execute }

initialization

end.

 

 

窗体调用单元:

 

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, rsrFtpDown, ComCtrls, StdCtrls;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Label1: TLabel;
    Button1: TButton;
    Memo1: TMemo;
    ProgressBar1: TProgressBar;
    StaticText1: TStaticText;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
    procedure FtpDownEvent(Sender: TObject; ADownFileObj: TADownFileObj; EventMode: TFTPEventMode; ErrorMsg:string);
  public
    { Public declarations }
    procedure AddMsg (AMsg: String);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.AddMsg(AMsg: String);
begin
  Memo1.Lines.Add(Format ('[%s] %s', [TimeToStr(Now), AMsg]));
end;

procedure TForm1.Button1Click(Sender: TObject);
var ADownFileObj:TADownFileObj;
    dsInfo:TDownServerInfo;
begin
  if GetDownServerInfo (Edit1.Text, dsInfo) then begin

    FtpDown ('', dsInfo.FRemoteFile, dsInfo.FHost, dsInfo.FUserName, dsInfo.FPassWord, dsInfo.FPort,
      FtpDownEvent);
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Memo1.Clear;
end;

procedure TForm1.FtpDownEvent(Sender: TObject; ADownFileObj: TADownFileObj;
  EventMode: TFTPEventMode; ErrorMsg: string);
var n: Integer;
begin
  Case EventMode of
    HEM_ADDURL:
    begin
      AddMsg ('AddUrl:'+ADownFileObj.Url);
    end;
    HEM_GETSIZE:
    begin
      AddMsg ('GetFileSize:'+IntToSTr(ADownFileObj.FileSize));
      self.ProgressBar1.Max := ADownFileObj.FileSize;
    end;
    HEM_WORK:
    begin
      AddMsg ('Work:'+IntToStr(ADownFileObj.DownSize));
      self.ProgressBar1.Position  := ADownFileObj.DownSize;
    end;
    HEM_DOWNOK:
    begin
      AddMsg ('DownOK:'+ADownFileObj.Url);
      ADownFileObj.Stream.SaveToFile(ExtractFilePath(Application.ExeName)+ADownFileObj.GetFileNameFromUrl(ADownFileObj.Url));
    end;
    HEM_BLOCKOK:
    begin
      n := TFtpGetObj(Sender).BlockNo;
      AddMsg (Format ('BlockOK(%d):%s',[n,ADownFileObj.Url]));
    end;
    HEM_SPEED:
    begin
      AddMsg ('Speed:'+ErrorMsg);
      self.StaticText1.Caption  :='速度:'+ErrorMsg;
    end;
    HEM_WORKBEGIN:
    begin
      AddMsg ('WorkBegin:'+ADownFileObj.Url);
      self.ProgressBar1.Position  := 0;
    end;
    HEM_ERROR:
    begin
      AddMsg ('Error:'+ErrorMsg);
    end;
  End;
end;

end.

 

  • 0
    点赞
  • 0
    评论
  • 4
    收藏
  • 打赏
    打赏
  • 扫一扫,分享海报

Delphi线程池实现线程FTP分段下载组件 by :renshouren mail:114032666@qq.com QQ:114032666 2019.10.05 使用的组件 1、TIdFTP Indy FTP客户端 2、TThreadsPool 线程池 工作原理及流程 调用本单元,将自动在程序初始化时生成线程池TThreadPoolDown实例 Share_ThreadPool_FTPDown 一、外部调用方法 外部只需要一次性调用 FtpDown() 函数向线程池加入下载任务,下载任务执行中的事件会通过调用时注册的 回调函数 AFtpDownEvent 进行通知。 二、内部工作流程 1、FtpDown()函数将调用TThreadPoolDown.AddFtpDown() ,然后调用TADownFileObj.MakeGetFileSizeObj()分配线程任务 本过程中,将向回调函数 AFtpDownEvent 触发 HEM_ADDURL 事件通知 2、工作线程调用任务对象TFTPHeadObj.DoThreadExecute 过程获取远程文件大小 备注:该功能实际使用到FTP命令SIZE,该命令一些老版本FTP服务器有可能不支持 本过程中,若获取文件大小成功,将向回调函数 AFtpDownEvent 触发 HEM_GETSIZE 事件通知, 若失败,则触发 HEM_ERROR 事件通知 3、得到远程文件大小后,调用TADownFileObj.MakeGetObjs(),分配获取远程文件线程任务 本过程中,开始时,将向回调函数 AFtpDownEvent 触发 HEM_WORKBEGIN 事件通知 在接收数据时,向回调函数 AFtpDownEvent 触发 HEM_WORK 事件通知 4、工作线程调用任务对象 TFTPGetObj.DoThreadExecute 实际下载远程文件数据块 每一个数据块下载任务完成后,触发 HEM_BLOCKOK 事件通知 5、所有数据块完成后,将调用 DoDownloadOK 函数,触发 HEM_DOWNOK 事件通知
©️2022 CSDN 皮肤主题:大白 设计师:CSDN官方博客 返回首页

打赏作者

rslxy

你的鼓励将是我创作的最大动力

¥2 ¥4 ¥6 ¥10 ¥20
输入1-500的整数
余额支付 (余额:-- )
扫码支付
扫码支付:¥2
获取中
扫码支付

您的余额不足,请更换扫码支付或充值

打赏作者

实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、C币套餐、付费专栏及课程。

余额充值