idftp.pas

photo.163.com 相册下载器 多线程下载

  FListResult := TIdStringList.Create;
  FLangsSupported := TIdStringList.Create;
  FCanResume := false;
  FResumeTested := false;
  FProxySettings:= TIdFtpProxySettings.Create; //APR
  FClientInfo := TIdFTPClientIdentifier.Create;
  FTZInfo := TIdFTPTZInfo.Create;
  FTZInfo.FGMTOffsetAvailable := False;
  FUseMLIS := DEF_Id_TIdFTP_UseMIS;
  FUsedMLS := False;
  FCanUseMLS := False; //initialize MLIS flags
  //Settings specified by
  // http://www.ietf.org/internet-drafts/draft-preston-ftpext-deflate-00.txt
  FZLibCompressionLevel :=  DEF_ZLIB_COMP_LEVEL;
  FZLibWindowBits := DEF_ZLIB_WINDOW_BITS; //-15 - no extra headers
  FZLibMemLevel := DEF_ZLIB_MEM_LEVEL;
  FZLibStratagy := DEF_ZLIB_STRATAGY; // - default
end;

procedure TIdFTP.Connect;
var
  LHost: String;
  LPort: Integer;
  LBuf : String;
begin
  FCurrentTransferMode := dmStream;
  FTZInfo.FGMTOffsetAvailable := False;
   //FSSCNOn should be set to false to prevent problems.
  FSSCNOn := False;
  FUsingSFTP := False;
  FUsingCCC := False;
  if FUseExtensionDataPort then begin
    FUsingExtDataPort := True;
  end;
  FUsingNATFastTrack := False;
  try
    //APR 011216: proxy support
    LHost := FHost;
    LPort := FPort;
    try
      if (ProxySettings.ProxyType > fpcmNone) and (Length(ProxySettings.Host) > 0) then begin
        FHost := ProxySettings.Host;
        FPort := ProxySettings.Port;
      end;

      if (FUseTLS=utUseImplicitTLS) then
      begin
        //at this point, we treat implicit FTP as if it were explicit FTP with TLS
        FUsingSFTP := True;
      end;
      inherited Connect;
    finally
      FHost := LHost;
      FPort := LPort;
    end;//tryf
    GetResponse([220]);

    FGreeting.Assign(LastCmdResult);
    DoOnBannerBeforeLogin (FGreeting.FormattedReply);
    if AutoLogin then begin
      Login;
      DoAfterLogin;
      //Fast track is set only one time per connection and no more, even
      //with REINIT
      if TryNATFastTrack then begin
        DoTryNATFastTrack;
      end;

      if (FUseTLS=utUseImplicitTLS) then begin
       //at this point, we treat implicit FTP as if it were explicit FTP with TLS
       FUsingSFTP := True;
     end;
      // OpenVMS 7.1 replies with 200 instead of 215 - What does the RFC say about this?
     // if SendCmd('SYST', [200, 215, 500]) = 500 then begin  {do not localize}
     //Do not fault if SYST was not understood by the server.  Novel Netware FTP
     //may not understand SYST.
     if SendCmd('SYST') = 500 then begin  {do not localize}
        FSystemDesc := RSFTPUnknownHost;
      end else begin
        FSystemDesc := LastCmdResult.Text[0];
      end;
      if IsSiteZONESupported then
      begin
        if not FCanUseMLS then
        begin
          if SendCmd('SITE ZONE') = 210 then {do not localize}
          begin
            if LastCmdResult.Text.Count > 0 then
            begin
              LBuf := LastCmdResult.Text[0];
              //remove UTC from reply string "UTC-300"
              IdDelete(LBuf,1,3);
              FTZInfo.GMTOffset := MDTMOffset(LBuf);
              FTZInfo.FGMTOffsetAvailable := True;
            end;
          end;
        end;
      end;
      DoStatus(ftpReady, [RSFTPStatusReady]);
    end;

  except
    Disconnect;
    raise;
  end;
end;

procedure TIdFTP.SetTransferType(AValue: TIdFTPTransferType);
begin
  if AValue <> FTransferType then begin
    if not Assigned(FDataChannel) then begin
      FTransferType := AValue;
      if Connected then begin
        SendTransferType;
      end;
    end
  end;
end;

procedure TIdFTP.SendTransferType;
var
  s: string;
begin
  case TransferType of
    ftAscii: s := 'A';      {do not localize}
    ftBinary: s := 'I';     {do not localize}
  end;
  SendCmd('TYPE ' + s, 200); {do not localize}
end;

function TIdFTP.ResumeSupported: Boolean;
begin
  if FResumeTested then result := FCanResume
  else begin
    FResumeTested := true;
    FCanResume := Quote('REST 1') = 350;   {do not localize}
    result := FCanResume;
    Quote('REST 0');  {do not localize}
  end;
end;

procedure TIdFTP.Get(const ASourceFile: string; ADest: TIdStreamVCL; AResume: Boolean = false);
begin
  //for SSL FXP, we have to do it here because InternalGet is used by the LIST command
  //where SSCN is ignored.
  ClearSSCN;
  AResume := AResume and CanResume;
  DoBeforeGet; //APR
  InternalGet('RETR ' + ASourceFile, ADest, AResume);   {do not localize}
  DoAfterGet(ADest.VCLStream ); //APR
end;

procedure TIdFTP.Get(const ASourceFile: string; ADest: TStream; AResume: Boolean = false);
var LStream : TIdStreamVCL;
begin
  //for SSL FXP, we have to do it here because InternalGet is used by the LIST command
  //where SSCN is ignored.
  ClearSSCN;
  AResume := AResume and CanResume;
  LStream := TIdStreamVCL.Create(ADest);
  try
    Get(ASourceFile,LStream,AResume);
  finally
    FreeAndNil(LStream);
  end;
end;

procedure TIdFTP.Get(const ASourceFile, ADestFile: string; const ACanOverwrite: boolean = false;
  AResume: Boolean = false);
var
  LDestStream: TFileStream;
begin
  if FileExists(ADestFile) then begin
    AResume := AResume and CanResume;
    if ACanOverwrite and (not AResume) then begin
      DeleteFile(ADestFile);
      LDestStream := TFileStream.Create(ADestFile, fmCreate);
    end
    else begin
      if (not ACanOverwrite) and AResume then begin
        LDestStream := TFileStream.Create(ADestFile, fmOpenReadWrite or fmShareDenyWrite);
        LDestStream.Position := LDestStream.Size;
      end
      else begin
        raise EIdFTPFileAlreadyExists.Create(RSDestinationFileAlreadyExists);
      end;
    end;
  end
  else begin
    LDestStream := TFileStream.Create(ADestFile, fmCreate);
  end;

  try
    Get(ASourceFile, LDestStream, AResume);
  finally
    FreeAndNil(LDestStream);
  end;
end;

procedure TIdFTP.DoBeforeGet;
begin
  if Assigned(FOnBeforeGet) then
  begin
    FOnBeforeGet(Self);
  end;
end;

procedure TIdFTP.DoBeforePut (AStream: TStream);
begin
  if Assigned(FOnBeforePut) then
  begin
    FOnBeforePut(SELF,AStream);
  end;
end;

procedure TIdFTP.DoAfterGet (AStream: TStream);//APR
Begin
  if Assigned(FOnAfterGet) then
  begin
    FOnAfterGet(SELF,AStream);
  end;
End;//TIdFTP.AtAfterFileGet

procedure TIdFTP.DoAfterPut;
begin
  if Assigned(FOnAfterPut) then
  begin
    FOnAfterPut(Self);
  end;
end;

procedure TIdFTP.ConstructDirListing;
begin
  if not Assigned(FDirectoryListing) then begin
    if not (csDesigning in ComponentState) then begin
      DoFTPList;
    end;
    if not Assigned(FDirectoryListing) then begin
      FDirectoryListing := TIdFTPListItems.Create;
    end;
  end else begin
    FDirectoryListing.Clear;
  end;
end;

procedure TIdFTP.List(
  ADest: TIdStrings;
  const ASpecifier: string = '';      {do not localize}
  ADetails: Boolean = True);
var
  LDest: TIdStringStream;
  LTrans : TIdFTPTransferType;
  LStream : TIdStreamVCL;
begin
  if FCanUseMLS then begin
    ExtListDir(ADest);
    Exit;
  end;
  //Note that for LIST, it might be best to put the connection in ASCII
  //mode because some old servers such as TOPS20 might require this.  We restore it
  //if the original mode was not ASCII.  It's a good idea to do this anyway
  //because some clients still do this such as WS_FTP Pro and Microsoft's FTP Client.
  LTrans := Self.TransferType;
  if LTrans <> ftASCII then begin
    Self.TransferType := ftASCII;
  end;
  try
    LDest := TIdStringStream.Create(''); try
      LStream := TIdStreamVCL.Create(LDest); try
        InternalGet(Trim(iif(ADetails, 'LIST', 'NLST') + ' ' + ASpecifier), LStream); {do not localize}
      finally FreeAndNil(LStream); end;
      FreeAndNil(FDirectoryListing);
      FListResult.Text := LDest.DataString;
      if ADest <> nil then begin
        ADest.Assign(FListResult);
      end;
      FUsedMLS := False;
    finally FreeAndNil(LDest); end;
    DoOnRetrievedDir;
  finally
    if LTrans <> ftASCII then begin
      Self.TransferType := LTrans;
    end;
  end;
end;

procedure TIdFTP.InternalGet(const ACommand: string; ADest: TIdStreamVCL; AResume: Boolean = false);
var
  LIP: string;
  LPort: Integer;
  LResponse: Integer;
  LPasvCl : TIdTCPClient;
  LPortSv : TIdSimpleServer;

{  procedure ReadCompressedData(ACompressor : TIdZLibCompressorBase;  ADest : TIdStreamVCL; AIO : TIdIOHandler;
    const AZLibWindowBits : Integer);
  var LM : TStream;
    LS : TIdStreamVCL;
  begin
    LM := TMemoryStream.Create;
    LS := TIdStreamVCL.Create(LM);
    try
      AIO.ReadStream(LS, -1, True);
      LS.Position := 0;
      if LS.Size<>0 then
      begin
        ACompressor.DecompressFTPDeflate(LM, AZLibWindowBits, ADest.VCLStream);
      end;
    finally
      FreeAndNil(LS);
      FreeAndNil(LM);
    end;
  end;     }

begin
  DoStatus(ftpTransfer, [RSFTPStatusStartTransfer]);
  try
    if FPassive then begin
      SendPret(ACommand);
      //PASV or EPSV
      if FUsingExtDataPort then begin
        SendEPassive(LIP, LPort);
      end else begin
        SendPassive(LIP, LPort);
      end;
      FDataChannel := TIdTCPClient.Create(nil);
      LPasvCl := FDataChannel as TIdTCPClient;
      try
        InitDataChannel;

        LPasvCl.Host := LIP;
        LPasvCl.Port := LPort;

        if Assigned(FOnDataChannelCreate) then begin
          OnDataChannelCreate(Self, FDataChannel);
        end;

        LPasvCl.Connect;
        try
          if AResume then begin
            Self.SendCmd('REST ' + IntToStr(ADest.VCLStream.Position), [350]);   {do not localize}
          end;
          Self.IOHandler.WriteLn(ACommand);
          Self.GetResponse([125, 150, 154]); //APR: Ericsson Switch FTP
          if (FDataPortProtection = ftpdpsPrivate) then begin
            TIdSSLIOHandlerSocketBase(FDataChannel.IOHandler).Passthrough := False;
          end;
          if FCurrentTransferMode = dmStream then begin
            LPasvCl.IOHandler.ReadStream(ADest, -1, True);
          end else begin
            FCompressor.DecompressFTPFromIO( LPasvCl.IOHandler, FZLibWindowBits, ADest.VCLStream);
      //      ReadCompressedData(FCompressor, ADest, LPasvCl.IOHandler, FZLibWindowBits);
          end;
        finally
          LPasvCl.Disconnect;
        end;
      finally
        if Assigned(FOnDataChannelDestroy) then begin
          OnDataChannelDestroy(Self, FDataChannel);