ftpdownloadthread.pas

最好的局域网搜索软件

{--------------------------------------------------------------
Simple Example.
Implement simple FTP client with Socket API
FTP下载文件，支持断点序传
<[e-mail]>
--------------------------------------------------------------}

unit FtpDownloadThread;

interface

uses
  Windows, Messages, SysUtils, Classes, ComCtrls, Dialogs, WinSock, FileCtrl;

const
  TCP_PORT = 21;          //设定TCP端口号

type 
  TFtpStatus = class(TObject)
    Content: string;
  end;

  TFtpDownloadThread = class(TThread)
  private
    SvrAddr, FilePath: string;
    CmdSocket, DatSocket: integer;
    CmdAddrIn, DatAddrIn: TSockAddrIn;
    DatAddr: string;
    DatPort: WORD;
    Status: TFtpStatus;
    LocalSize, RemoteSize: integer;
    //Progress: real;
    procedure SendCmd(Content: string);
    procedure RecvReply(var Buf: array of char);
    function GetCode(s: string): string;
  public
    FtpUrl: string;
    UsrName, PassWord: string;
    LocalFile: string;
    OnStatusEvent: TNotifyEvent;
    MyListItem: TListItem;
    procedure Execute; override;
    procedure ShowStatus;
    procedure ShowProgress;
    procedure OpenFailed;
    procedure DownloadComplete;
  end;


implementation
uses Config;

{
in: url: 'ftp://x.x.x.x/aabb/ccdd/c.txt'
out: FptSvr: x.x.x.x
out: FtpDir: /aabb/ccdd/c.txt
}
procedure FtpUrl2AddrPath(url: string; var FtpSvr, FilePath: string);
var
  s: string;
  i: integer;
begin
  s := url;
  delete(s, 1, 6);
  i := pos('/', s);
  if i = 0 then
  begin
    FtpSvr := s;
    FilePath := '';
  end
  else
  begin
    FtpSvr := copy(s, 1, i-1);
    delete(s, 1, i-1);
    FilePath := s;
  end;
end;

{
function IsDigit(S: string): Boolean;
var
  i: integer;
begin
  for i := 1 to length(S) do
  if (ord(S[i]) < 48) or (ord(S[i]) > 57) then
  begin
    result := false;
    exit;
  end;
  result := true;
end;
}

function TFtpDownloadThread.GetCode(s: string): string;
var
  i: integer;
  buf: array[0..255] of char;
begin

  while s[4] = '-' do
  begin
    RecvReply(buf);
    s := buf;

    i := pos(#13+#10, s);
    while (i <> length(s)-1)and(i<>0) do
    begin
      //s := copy(s, i+1, length(s)-i-1);
      delete(s, 1, i+1);
      i := pos(#13+#10, s);
    end;

  end;

  i := pos(' ', s);
  result := copy(s, 1, i-1);

  {
  if not IsDigit(result) then
  begin
    i := pos('-', s);
    result := copy(s, 1, i-1);
  end;
  }

end;

function GetPwd(str: string): string;
var
  i: integer;
  s: string;
begin
  i := pos('"', str);
  delete(str, 1, i);
  i := pos('"', str);
  s := copy(str, 1, i-1);
  result := s;
end;

{
 get ip addr and tcp port from PASV reply
}
procedure GetDatSocketAddrPort(str: string; var Addr: string; var Port: WORD);
var
  sl: TStringList;
  s: string;
  i: integer;
begin

  i := pos('(', str);
  s := Copy(str, i+1, length(str));
  str := s;
  i := pos(')', str);
  s := Copy(str, 1, i-1);

  sl := TStringList.Create;
  sl.CommaText := s;
  Addr := sl[0] + '.' + sl[1] + '.' + sl[2] + '.' + sl[3];
  Port := strtoint(sl[4])*256 + strtoint(sl[5]);
  sl.Free;
end;

{
 get file size from RETR reply
}
function GetRemoteSize(str: string): integer;
var
  i: integer;
  s: string;
begin
  //Windows.MessageBox(0, pchar(str), '错误', mb_ok);
  i := pos('(', str);
  s := Copy(str, i+1, length(str));
  str := s;
  i := pos(')', str);
  s := Copy(str, 1, i-1);

  i := pos(' ', s);
  str := copy(s, 1, i-1);
  str := trim(str);
  if str <> '' then
    result := strtoint(str)
  else result := -1;
end;

{
 get file size from SIZE reply
}
function GetRemoteSize2(str: string): integer;
var
  i: integer;
  s: string;
begin
  s := str;
  i := pos(' ', s);
  Delete(s, 1, i);
  //Windows.MessageBox(0, pchar(s), '错误', mb_ok);
  s := trim(s);
  result := strtoint(s);
end;

procedure TFtpDownloadThread.OpenFailed;
begin
  MyListItem.ImageIndex := 25;
  ShowMessage(Status.Content);
end;

procedure TFtpDownloadThread.ShowProgress;
var
  percent: integer;
begin

  if RemoteSize <> -1 then
  begin
    percent := Round((LocalSize/RemoteSize)*100);
    MyListItem.SubItems[1]:= inttostr(percent)+'%';
    //if percent>=100 then MyListItem.ImageIndex :=24;
  end
  else
  begin
    if LocalSize > 1024 then
      MyListItem.SubItems[1]:= inttostr(Round(LocalSize/1024))+'KB'
    else MyListItem.SubItems[1]:= inttostr(LocalSize)+'B';
  end;

end;

procedure TFtpDownloadThread.DownloadComplete;
begin
  MyListItem.ImageIndex :=24;
end;

procedure TFtpDownloadThread.Execute;
var
  WsaData: TWsadata;
  err, len: integer;
  Buf: array[0..1023] of char;

  fo       : TFileStream;
  FileExist: boolean;
  pwd: string;

  s: string;
  i: integer;
  GuessSucceed: boolean;

  DirName: string;
begin

  FtpUrl2AddrPath(FtpUrl, SvrAddr, FilePath);
  ConfigForm.GiveFtpUserPassWord(SvrAddr, UsrName, PassWord);
  Status := TFtpStatus.Create;

  WSAStartup($0101,WSAData);
  
  CmdSocket := socket(AF_INET, SOCK_STREAM,IPPROTO_IP);

  if (CmdSocket = INVALID_SOCKET) then
  begin
    Windows.MessageBox(0, pchar(inttostr(WSAGetLastError())+'  Socket创建失败'), '错误', mb_ok); 
    CloseSocket(CmdSocket);
    Synchronize(OpenFailed);
    exit;
  end;

  CmdAddrIn.sin_addr.s_addr:=inet_addr(PChar(SvrAddr));
  CmdAddrIn.sin_family := AF_INET;
  CmdAddrIn.sin_port :=htons(TCP_PORT);
  err:=connect(CmdSocket,CmdAddrIn, SizeOf(CmdAddrIn));

  RecvReply(Buf);

  SendCmd('USER '+UsrName);
  RecvReply(Buf);
  if (GetCode(buf) <> '331'){and(GetCode(buf) <> '220')} then
  begin
    Synchronize(OpenFailed);
    exit;
  end;

  SendCmd('PASS '+PassWord);
  RecvReply(Buf);
  if GetCode(buf) <> '230' then
  begin
    //------------------------guess-------------------------
    GuessSucceed := false;

    for i := 0 to ConfigForm.lvFtpMountList.Items.Count-1 do
    begin
      s := ConfigForm.lvFtpMountList.Items[i].Caption;
      if s =  '*' then
      begin
        UsrName := ConfigForm.lvFtpMountList.Items[i].SubItems[0];
        //PassWord := ConfigForm.lvFtpMountList.Items[i].SubItems[1];
        PassWord := ConfigForm.FtpPassList.Strings[i];

        SendCmd('USER '+UsrName);
        RecvReply(Buf);
        if (GetCode(buf) = '331') then
        begin
          SendCmd('PASS '+PassWord);
          RecvReply(Buf);
          if GetCode(buf) = '230' then
          begin
            GuessSucceed := true;
            break;
          end;
        end;
      end;
    end;
    //------------------------------------------------------
    if (not GuessSucceed) then
    begin
      Synchronize(OpenFailed);
      exit;
    end;
  end;

  SendCmd('PWD');
  RecvReply(Buf);
  if GetCode(buf) <> '257' then
  begin
    Synchronize(OpenFailed);
    exit;
  end;
  pwd := GetPwd(Buf);
  ///ShowMessage(pwd);
  if pwd <> '/' then FilePath := pwd + FilePath;

  SendCmd('TYPE I');
  RecvReply(Buf);
  if GetCode(buf) <> '200' then
  begin
    Synchronize(OpenFailed);
    exit;
  end;

  SendCmd('PASV');
  RecvReply(Buf);
  if GetCode(buf) <> '227' then
  begin
    Synchronize(OpenFailed);
    exit;
  end;

  GetDatSocketAddrPort(buf, DatAddr, DatPort);
  DatSocket := socket(AF_INET, SOCK_STREAM,IPPROTO_IP);
  DatAddrIn.sin_addr.s_addr:=inet_addr(PChar(DatAddr));
  DatAddrIn.sin_family := AF_INET;
  DatAddrIn.sin_port := htons(DatPort);
  err := connect(DatSocket,DatAddrIn, SizeOf(DatAddrIn));

  LocalSize := 0;
  FileExist := FileExists(LocalFile);
  if FileExist then
  begin
    fo := TFileStream.Create(LocalFile, fmOpenReadWrite);
    fo.Position:=fo.size;
    LocalSize := fo.size;
  end;

  repeat
    SendCmd('REST '+inttostr(LocalSize));
    RecvReply(Buf);
    if GetCode(buf) <> '350' then
    begin
      Synchronize(OpenFailed);
      exit;
    end;
    //Windows.MessageBox(0, pchar(@Buf[0]), '错误', mb_ok);

    SendCmd('RETR '+FilePath);
    RecvReply(Buf);
  until ((GetCode(buf) = '150') or (GetCode(buf) = '125'));

  RemoteSize := GetRemoteSize(buf);

  if (RemoteSize = -1)and(GetCode(buf) <> '125') then
  begin
    SendCmd('SIZE '+FilePath);
    RecvReply(Buf);
    //Windows.MessageBox(0, pchar(@Buf[0]), '错误', mb_ok);
    if GetCode(buf) = '213' then
      RemoteSize := GetRemoteSize2(buf);
  end;

  if not FileExist then
  begin
    DirName := ExtractFilePath(LocalFile);
    if not DirectoryExists(DirName) then ForceDirectories(DirName);

    fo := TFileStream.Create(LocalFile, fmCreate);
  end;
  
  while true do
  begin
    len := Recv(DatSocket, Buf, 1024, 0);
    if len < 1 then break;
    fo.WriteBuffer(buf[0], len);

    //Status.Content := '>>'+inttostr(fo.Position)+'/'+inttostr(RemoteSize);
    //Synchronize(ShowStatus);
    //Progress := fo.Position/RemoteSize;
    LocalSize :=  fo.Position;
    Synchronize(ShowProgress);
  end;

  synchronize(DownloadComplete);

  fo.Free;

  Status.Content := '>>Complete!';
  Synchronize(ShowStatus);
  
  CloseSocket(CmdSocket);
  CloseSocket(DatSocket);
  Status.Free;
    
end;

procedure TFtpDownloadThread.ShowStatus;
begin
  if assigned(OnStatusEvent) then OnStatusEvent(Status);
end;

procedure TFtpDownloadThread.SendCmd(Content: string);
begin
  Content := Content +#13+#10;
  Send(CmdSocket, Content[1], length(Content), 0);

  Status.Content := '>' + Content;
  Synchronize(ShowStatus);
end;

procedure TFtpDownloadThread.RecvReply(var Buf: array of char);
var
  len: integer;
begin
  len := Recv(CmdSocket, Buf, 1024, 0);
  Buf[len] := #0;

  Status.Content := Buf;
  Synchronize(ShowStatus);
end;

end.