idftp.pas

delphi indy9.0.18组件包

  LDestStream: TFileStream;
begin
  if FileExists(ADestFile) then begin
    AResume := AResume and CanResume;
    if ACanOverwrite and (not AResume) then begin
      LDestStream := TFileStream.Create(ADestFile, fmCreate);
    end
    else begin
      if (not ACanOverwrite) and AResume then begin
        LDestStream := TFileStream.Create(ADestFile, fmOpenReadWrite or fmShareDenyWrite);
        LDestStream.Seek(0, soFromEnd);
      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.DoAfterGet (AStream: TStream);//APR
Begin
  if Assigned(FOnAfterGet) then FOnAfterGet(SELF,AStream);
End;//TIdFTP.AtAfterFileGet


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;
    FDirectoryListing.OnParseCustomListFormat := FOnParseCustomListFormat;
  end else begin
    FDirectoryListing.Clear;
  end;
end;

procedure TIdFTP.List(ADest: TStrings; const ASpecifier: string = '';      {Do not translate}
 const ADetails: boolean = true);
var
  LDest: TStringStream;
begin
  LDest := TStringStream.Create(''); try   {Do not translate}
    if ADetails then begin
      InternalGet(trim('LIST ' + ASpecifier), LDest);  {Do not translate}
    end else begin
      InternalGet(trim('NLST ' + ASpecifier), LDest);  {Do not trnalstate}
    end;
    FreeAndNil(FDirectoryListing);
    if Assigned(ADest) then begin //APR: User can use ListResult and DirectoryListing
      ADest.Text := LDest.DataString;
    end;
    FListResult.Text := LDest.DataString;
  finally FreeAndNil(LDest); end;
end;

procedure TIdFTP.InternalGet(const ACommand: string; ADest: TStream; AResume: Boolean = false);
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
            if AResume then begin
              Self.SendCmd('REST ' + IntToStr(ADest.Position), [350]);   {Do not tranlsate}
            end;
            Self.WriteLn(ACommand);
            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);
          if AResume then begin
            Self.SendCmd('REST ' + IntToStr(ADest.Position), [350]);  {Do not translate}
          end;
          Self.SendCmd(ACommand, [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;

procedure TIdFTP.Quit;
begin
  if Connected then begin
    WriteLn('QUIT');      {Do not translate}
  end;
  Disconnect;
end;

procedure TIdFTP.KillDataChannel;
begin
  // Had kill the data channel ()
  if Assigned(FDataChannel) then begin
    FDataChannel.DisconnectSocket;
  end;
end;

procedure TIdFTP.Abort;
begin
  // only send the abort command. The Data channel is supposed to disconnect
  if Connected then begin
    WriteLn('ABOR');                   {Do not translate}
  end;
  // Kill the data channel: usually, the server doesn't close it by itself
  KillDataChannel;
end;

procedure TIdFTP.SendPort(AHandle: TIdSocketHandle);
begin
  SendCmd('PORT ' + StringReplace(AHandle.IP, '.', ',', [rfReplaceAll])   {Do not translate}
   + ',' + IntToStr(AHandle.Port div 256) + ',' + IntToStr(AHandle.Port mod 256), [200]); {Do not translate}
end;

procedure TIdFTP.InternalPut(const ACommand: string; ASource: TStream; AFromBeginning: Boolean = true);
var
  LIP: string;
  LPort: Integer;
  LResponse: Integer;
begin
  DoStatus(ftpTransfer, [RSFTPStatusStartTransfer]); try
    if FPassive then begin
      SendPassive(LIP, LPort);
      WriteLn(ACommand);
      FDataChannel := TIdTCPClient.Create(nil);
      with TIdTCPClient(FDataChannel) do try
        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
          Self.GetResponse([110, 125, 150]);
          try
            WriteStream(ASource, {false}AFromBeginning);
          except
            on E: EIdSocketError do begin
              // If 10038 - abort was called. Server will return 225
              if E.LastError <> 10038 then begin
                raise;
              end;
            end;
          end;
        finally Disconnect; 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);
          Self.SendCmd(ACommand, [125, 150]);
          Listen;
          WriteStream(ASource, AFromBeginning);
        end;
      finally FreeAndNil(FDataChannel); end;
    end;
  finally
    DoStatus(ftpReady, [RSFTPStatusDoneTransfer]);
  end;
  // 226 = download successful, 225 = Abort successful}
  LResponse := GetResponse([225, 226, 250, 426, 450]);
  if (LResponse = 426) or (LResponse = 450) then begin
    // some servers respond with 226 on ABOR
    GetResponse([226, 225]);
    DoStatus(ftpAborted, [RSFTPStatusAbortTransfer]);
  end;
end;

procedure TIdFTP.InitDataChannel;
begin
  FDataChannel.SendBufferSize := SendBufferSize;
  FDataChannel.RecvBufferSize := RecvBufferSize;
  FDataChannel.OnWork := OnWork;
  FDataChannel.OnWorkBegin := OnWorkBegin;
  FDataChannel.OnWorkEnd := OnWorkEnd;
end;

procedure TIdFTP.Put(const ASource: TStream; const ADestFile: string = '';
 const AAppend: boolean = false);
begin
  if length(ADestFile) = 0 then begin
    InternalPut('STOU ' + ADestFile, ASource);  {Do not localize}
  end else if AAppend then begin
    InternalPut('APPE ' + ADestFile, ASource, false);  {Do not localize}
  end else begin
    InternalPut('STOR ' + ADestFile, ASource);  {Do not localize}
  end;
end;

procedure TIdFTP.Put(const ASourceFile: string; const ADestFile: string = '';
 const AAppend: boolean = false);
var
  LSourceStream: TFileStream;
begin
  LSourceStream := TFileStream.Create(ASourceFile, fmOpenRead or fmShareDenyNone); try
    Put(LSourceStream, ADestFile, AAppend);
  finally FreeAndNil(LSourceStream); end;
end;

procedure TIdFTP.SendPassive(var VIP: string; var VPort: integer);
var
  i,bLeft,bRight: integer;
  s: string;
begin
  SendCmd('PASV', 227);      {Do not translate}
  s := Trim(LastCmdResult.Text[0]);
  // Case 1 (Normal)
  // 227 Entering passive mode(100,1,1,1,23,45)
  bLeft := IndyPos('(', s);   {Do not translate}
  bRight := IndyPos(')', s);  {Do not translate}
  if (bLeft = 0) or (bRight = 0) then begin
    // Case 2
    // 227 Entering passive mode on 100,1,1,1,23,45
    bLeft := RPos(#32, s);
    s := Copy(s, bLeft + 1, Length(s) - bLeft);
  end else begin
    s := Copy(s, bLeft + 1, bRight - bLeft - 1);
  end;
  VIP := '';                 {Do not translate}
  for i := 1 to 4 do begin
    VIP := VIP + '.' + Fetch(s, ','); {Do not translate}
  end;
  System.Delete(VIP, 1, 1);
  // Determine port
  VPort := StrToInt(Fetch(s, ',')) shl 8;   {Do not translate}
  //use trim as one server sends something like this:
  //"227 Passive mode OK (195,92,195,164,4,99 )"
  VPort := VPort + StrToInt(Trim(Fetch(s, ','))); {Do not translate}
end;

procedure TIdFTP.Noop;
begin
  SendCmd('NOOP', 200);     {Do not translate}
end;

procedure TIdFTP.MakeDir(const ADirName: string);
begin
  SendCmd('MKD ' + ADirName, 257);  {Do not translate}
end;

function TIdFTP.RetrieveCurrentDir: string;
begin
  SendCmd('PWD', 257);              {Do not translate}
  Result := CleanDirName(LastCmdResult.Text[0]);
end;

procedure TIdFTP.RemoveDir(const ADirName: string);
begin
  SendCmd('RMD ' + ADirName, 250);  {Do not translate}
end;

procedure TIdFTP.Delete(const AFilename: string);
begin
  SendCmd('DELE ' + AFilename, 250);  {Do not translate}
end;

(*
CHANGE WORKING DIRECTORY (CWD)

  This command allows the user to work with a different
  directory or dataset for file storage or retrieval without
  altering his login or accounting information.  Transfer
  parameters are similarly unchanged.  The argument is a
  pathname specifying a directory or other system dependent
  file group designator.

CWD
  250
  500, 501, 502, 421, 530, 550
*)
procedure TIdFTP.ChangeDir(const ADirName: string);
begin
  SendCmd('CWD ' + ADirName, [200, 250]); //APR: Ericsson Switch FTP     {Do not translate}
end;

(*