idftp.pas

delphi indy9.0.18组件包

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
  // RFC lists 200 as the proper response, but in another section says that it can return the
  // same as CWD, which expects 250. That is it contradicts itself.
  // MS in their infinite wisdom chnaged IIS 5 FTP to return 250.
  SendCmd('CDUP', [200, 250]);   {Do not translate}
end;

procedure TIdFTP.Site(const ACommand: string);
begin
  SendCmd('SITE ' + ACommand, 200);   {Do not translate}
end;

procedure TIdFTP.Rename(const ASourceFile, ADestFile: string);
begin
  SendCmd('RNFR ' + ASourceFile, 350);  {Do not translate}
  SendCmd('RNTO ' + ADestFile, 250);    {Do not translate}
end;

function TIdFTP.Size(const AFileName: String): Integer;
var
  SizeStr: String;
begin
  result := -1;
  if SendCmd('SIZE ' + AFileName) = 213 then begin  {Do not translate}
    SizeStr := Trim(LastCmdResult.Text.Text);
    system.delete(SizeStr, 1, IndyPos(' ', SizeStr)); // delete the response   {Do not translate}
    result := StrToIntDef(SizeStr, -1);
  end;
end;

//Added by SP
procedure TIdFTP.ReInitialize(ADelay: Cardinal = 10);
begin
  Sleep(ADelay); //Added
  if SendCmd('REIN', [120, 220, 500]) <> 500 then begin  {Do not translate}
    FLoginMsg.Clear;
    FCanResume := False;
    FDirectoryListing.Clear;
    FUsername := '';                 {Do not translate}
    FPassword := '';                 {Do not translate}
    FPassive := Id_TIdFTP_Passive;
    FCanResume := False;
    FResumeTested := False;
    FSystemDesc := '';
    FTransferType := Id_TIdFTP_TransferType;
  end;
end;

procedure TIdFTP.Allocate(AAllocateBytes: Integer);
begin
  SendCmd('ALLO ' + IntToStr(AAllocateBytes), [200]); {Do not translate}
end;

procedure TIdFTP.Status(var AStatusList: TStringList);
var
  LStrm: TStringStream;
  LList: TStringList;
begin
  if SendCmd('STAT', [211, 212, 213, 500]) <> 500 then   {Do not translate}
  begin
    if not Assigned(FDirectoryListing) then
    begin
      DoFTPList;
    end;
    LStrm := TStringStream.Create('');      {Do not translate}
    LList := TStringList.Create;
    //Read stream through control connection - not data channel
    ReadStream(LStrm, -1, True);
    LList.Text := LStrm.DataString;
    try
      try
        ConstructDirListing;
        FDirectoryListing.Clear;
      except
        on EAccessViolation do ConstructDirListing;
      end;
      // Parse directory listing
      if LList.Count > 0 then
      begin
        FDirectoryListing.ListFormat := FDirectoryListing.CheckListFormat(LList[0], True);
        DoCheckListFormat(LList[0]);
        FDirectoryListing.LoadList(LList);
      end;
    except
      if Assigned(AStatusList) = True then
      begin
        AStatusList.Text := LStrm.DataString;
      end;
    end;
    FreeAndNil(LStrm);
    FreeAndNil(LList);
  end;
end;

procedure TIdFTP.Help(var AHelpContents: TStringList; ACommand: String = ''); {Do not translate}
var
  LStrm: TStringStream;
begin
  LStrm := TStringStream.Create('');    {Do not translate}
  if SendCmd('HELP ' + ACommand, [211, 214, 500]) <> 500 then       {Do not translate}
  begin
    ReadStream(LStrm, -1, True);
    AHelpContents.Text := LStrm.DataString;
  end;
  FreeAndNil(LStrm);
end;

procedure TIdFTP.Account(AInfo: String);
begin
  SendCmd('ACCT ' + AInfo, [202, 230, 500]);   {Do not translate}
end;

procedure TIdFTP.StructureMount(APath: String);
begin
  SendCmd('SMNT ' + APath, [202, 250, 500]);  {Do not translate}
end;

procedure TIdFTP.FileStructure(AStructure: TIdFTPDataStructure);
var
  s: String;
begin
  case AStructure of
    dsFile: s := 'F';         {Do not translate}
    dsRecord: s := 'R';       {Do not translate}
    dsPage: s := 'P';         {Do not translate}
  end;
  SendCmd('STRU ' + s, [200, 500]);  {Do not translate}
  { TODO: Needs to be finished }
end;

procedure TIdFTP.TransferMode(ATransferMode: TIdFTPTransferMode);
var
  s: String;
begin
  case ATransferMode of
    dmBlock: begin
      s := 'B';                {Do not translate}
    end;
    dmCompressed: begin
      s := 'C';                {Do not translate}
    end;
    dmStream: begin
      s := 'S';                {Do not translate}
    end;
  end;
  SendCmd('MODE ' + s, [200, 500]);  {Do not translate}
  { TODO: Needs to be finished }
end;

destructor TIdFTP.Destroy;
begin
  FreeAndNil(FListResult);
  FreeAndNil(FLoginMsg);
  FreeAndNil(FDirectoryListing);
  FreeAndNIL(FProxySettings); //APR
  inherited Destroy;
end;

function TIdFTP.Quote(const ACommand: String): SmallInt;
begin
  result := SendCmd(ACommand);
end;

//APR 011216: ftp proxy support
// TODO: need help - "//?"
procedure TIdFTP.Login;
begin
  case ProxySettings.ProxyType of
  fpcmNone:
    begin
      if SendCmd('USER ' + FUserName, [230, 331]) = 331 then begin   {Do not translate}
        SendCmd('PASS ' + FPassword, 230);                           {Do not translate}
      end;
    end;//fpcmNone
  fpcmUserSite:
    begin
      if (Length(ProxySettings.UserName)>0) then begin
        if SendCmd('USER ' + ProxySettings.UserName, [230, 331]) = 331 then begin  {Do not translate}
          SendCmd('PASS ' + ProxySettings.Password, 230);             {Do not translate}
        end;
      end;//proxy login
      if SendCmd('USER ' + FUserName+'@'+FHost, [230, 331]) = 331 then begin     {Do not translate}
        SendCmd('PASS ' + FPassword, 230);                       {Do not translate}
      end;
    end;//fpcmUserSite
  fpcmSite:
    begin
      if (Length(ProxySettings.UserName)>0) then begin
        if SendCmd('USER ' + ProxySettings.UserName, [230, 331]) = 331 then begin  {Do not translate}
          SendCmd('PASS ' + ProxySettings.Password, 230);  {Do not translate}
        end;
      end;//proxy login
      SendCmd('SITE '+FHost);//? Server Reply? 220?
      if SendCmd('USER ' + FUserName, [230, 331]) = 331 then begin {Do not translate}
        SendCmd('PASS ' + FPassword, 230);    {Do not translate}
      end;
    end;//fpcmSite
  fpcmOpen:
    begin
      if (Length(ProxySettings.UserName)>0) then begin
        if SendCmd('USER ' + ProxySettings.UserName, [230, 331]) = 331 then begin   {Do not translate}
          SendCmd('PASS ' + ProxySettings.Password, 230);   {Do not translate}
        end;
      end;//proxy login
      SendCmd('OPEN '+FHost);//? Server Reply? 220?     {Do not translate}
      if SendCmd('USER ' + FUserName, [230, 331]) = 331 then begin  {Do not translate}
        SendCmd('PASS ' + FPassword, 230);         {Do not translate}
      end;
    end;//fpcmSite
  fpcmUserPass: //USER user@firewalluser@hostname / PASS pass@firewallpass
    begin
      if SendCmd(Format('USER %s@%s@%s',[FUserName,ProxySettings.UserName,FHost]), [230, 331])=331 then begin    {Do not translate}
        if Length(ProxySettings.Password)>0 then begin
          SendCmd('PASS '+FPassword+'@'+ProxySettings.Password, 230); {Do not translate}
        end
        else begin
          SendCmd('PASS '+FPassword, 230); {Do not translate}
        end;//if @
      end;
    end;//fpcmUserPass
  fpcmTransparent: //? +Host
    begin
      if (Length(ProxySettings.UserName)>0) then begin
        if SendCmd('USER ' + ProxySettings.UserName, [230, 331]) = 331 then begin    {Do not translate}
          SendCmd('PASS ' + ProxySettings.Password, 230);     {Do not translate}
        end;
      end;//proxy login
      if SendCmd('USER ' + FUserName, [230, 331]) = 331 then begin   {Do not translate}
        SendCmd('PASS ' + FPassword, 230);  {Do not translate}
      end;
    end;//fpcmTransparent
  fpcmHttpProxyWithFtp:
    begin
{GET ftp://XXX:[e-mail]/ HTTP/1.0
Host: indy.nevrona.com
User-Agent: Mozilla/4.0 (compatible; Wincmd; Windows NT)
Proxy-Authorization: Basic B64EncodedUserPass==
Connection: close}
      raise EIdException.Create(RSSocksServerCommandError);
    end;//fpcmHttpProxyWithFtp
  end;//case
  FLoginMsg.Assign(LastCmdResult);
  SendTransferType;
End;//TIdFTP.Login

procedure TIdFTP.DoAfterLogin;
begin
  if Assigned(FOnAfterClientLogin) then begin
    OnAfterClientLogin(self);
  end;
end;

procedure TIdFTP.DoFTPList;
begin
  if Assigned(FOnCreateFTPList) then begin
    FOnCreateFTPList(self, FDirectoryListing);
  end;
end;

procedure TIdFTP.DoCheckListFormat(const ALine: String);
Var
  LListFormat: TIdFTPListFormat;
Begin
  if Assigned(FOnCheckListFormat) then begin //APR: User always right!
    LListFormat := FDirectoryListing.ListFormat; //APR: user MUST see Indy opinion
    OnCheckListFormat(Self, ALine, LListFormat);
    FDirectoryListing.ListFormat := LListFormat;
  end;
End;//TIdFTP.DoCheckListFormat

function TIdFTP.GetDirectoryListing: TIdFTPListItems;
begin
  if not Assigned(FDirectoryListing) then begin
    try
      ConstructDirListing;
    except
      on EAccessViolation do ConstructDirListing;
    end;
    // Parse directory listing
    if FListResult.Count > 0 then begin
      FDirectoryListing.ListFormat := FDirectoryListing.CheckListFormat(FListResult[0],TRUE);//APR: TRUE for IndyCheck, else always Unknown
      DoCheckListFormat(FListResult[0]);
      FDirectoryListing.LoadList(FListResult);
    end;
  end;
  Result := FDirectoryListing;
end;

procedure TIdFTP.SetOnParseCustomListFormat(const AValue: TIdOnParseCustomListFormat);
begin
  FOnParseCustomListFormat := AValue;
  if Assigned(FDirectoryListing) then begin
    FDirectoryListing.OnParseCustomListFormat := AValue;
  end;
end;

procedure TIdFTP.SetProxySettings(const Value: TIdFtpProxySettings);
Begin
  FProxySettings.Assign(Value);
End;//

{ TIdFtpProxySettings }

procedure TIdFtpProxySettings.Assign(Source: TPersistent);
Begin
  if Source is TIdFtpProxySettings then begin
    with TIdFtpProxySettings(Source) do begin
      SELF.FProxyType  := ProxyType;
      SELF.FHost := Host;
      SELF.FUserName := UserName;
      SELF.FPassword := Password;
      SELF.FPort := Port;
    end;
  end
  else begin
    inherited Assign(Source);
  end;
End;//


end.