idftp.pas

Indy控件的使用源代码

  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;
  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;
          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;
          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}
  VPort := VPort + StrToInt(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;

(*
CHANGE TO PARENT DIRECTORY (CDUP)

  This command is a special case of CWD, and is included to
  simplify the implementation of programs for transferring
  directory trees between operating systems having different
  syntaxes for naming the parent directory.  The reply codes
  shall be identical to the reply codes of CWD.  See
  Appendix II for further details.

CDUP
  200
  500, 501, 502, 421, 530, 550
*)
procedure TIdFTP.ChangeDirUp;
begin