ftp.pas

Monster FTP Client 强大的ftp客户控件,支持Proxy等

               filelist.free;
               dirlist.free;

               FBusy := False;
               {$ifdef HAVE_OVERLOAD}
               RenameFile(S, D);
               {$else}
               RenameFiles(S, D);
               {$endif}
            end
            else
            begin
               Ready;
            end;
         end
         else
         begin
            DoFtpInfo(ftpSizeDifferent, '');
            FSuccess := False;
            Ready;
         end;
      end;
   end;
end;

procedure TMFtp.RenameFile(oldname, newname: String);
begin
   if (CheckStatus) and (oldname <> '') and (oldname <> newname) then
   begin
      FTPLastAction := ftplaREN;
      rnto := newname;
      Proceed('RNFR ' + oldname, 40);
   end;
end;

{$ifdef HAVE_OVERLOAD}
procedure TMFtp.RenameFile(oldlist, newlist: TStrings);
{$else}
procedure TMFtp.RenameFiles(oldlist, newlist: TStrings);
{$endif}
var filename: String;
begin
   if CheckStatus then
   begin
      if Assigned(oldlist) and Assigned(newlist) then
      begin
         if oldlist.Count = newlist.count then
         begin
            if oldlist.Count > 0 then
            begin
               FTPLastAction := ftplaREN;
               FFList.Assign(oldlist);
               FDList.Assign(newlist);
               filename := FFList[0];
               rnto := FDList[0];
               FFList.Delete(0);
               FDList.Delete(0);
               Proceed('RNFR ' + filename, 320);
            end
            else
            begin
               Ready;
            end;
         end
         else
         begin
            DoFtpInfo(ftpSizeDifferent, '');
            FSuccess := False;
            Ready;
         end;
      end;
   end;
end;

procedure TMFtp.LoadIndexFile;
begin
// if (not CheckStatus) or (Trim(Filename) = '') then Exit;

   FIFile := GetTempFilename;
   FTPLastAction := ftplaGETIndexFile;

   GetFile(Filename, FIFile);
end;

procedure TMFtp.GetFile(RemoteFile, LocalFile: String);
var p: Integer;
begin
   if not CheckStatus then Exit;

   if FTPLastAction <> ftplaGETIndexFile then
      FTPLastAction := ftplaGET;

   FSelection := RemoteFile;
   FFile := LocalFile;

   if FSelection = '' then
   begin
      DoFtpError(ftpFileNotFound);
      Ready;
      Exit;
   end;
   if FFile <> '' then
   begin
      try
         FileMode := 2;
         AssignFile(datafile, FFile);
         if SysUtils.FileExists(FFile) then
         begin
            Reset(datafile, 1);
            p := 20;
         end
         else
         begin
            Rewrite(datafile, 1);
            p := 21;
         end;

         FileOpened := True;
         ReadyPort := False;
         ReadyMain := False;

         if FMode = BinaryTransfer then
            SetTransferMode('I', p)
         else
            SetTransferMode('A', p);
      except
         DoFtpError(ftpFileOpen);
         Ready;
      end;
   end
   else
   begin
      DoFtpError(ftpFileOpen);
      Ready;
      Exit;
   end;
end;

procedure TMFtp.PutFile(LocalFile, RemoteFile: String);
begin
   if not CheckStatus then Exit;

   FTPLastAction := ftplaPUT;
   FSelection := RemoteFile;
   FFile := LocalFile;

   if FSelection = '' then
   begin
      DoFtpError(ftpFileNotFound);
      Ready;
      Exit;
   end;
   if FFile <> '' then
   begin
      try
         FileMode := 0;
         AssignFile(datafile, FFile);
         Reset(datafile, 1);
         FileOpened := True;
      except
         DoFtpError(ftpFileOpen);
         Ready;
         Exit;
      end;
   end
   else
   begin
      DoFtpError(ftpFileOpen);
      Ready;
      Exit;
   end;
   if FMode = BinaryTransfer then
      SetTransferMode('I', 30)
   else
      SetTransferMode('A', 30);
end;

procedure TMFtp.IssueCommand;
begin
   if CheckStatus then
   begin
      CurrentMode := '';
      Proceed(command, 50);
   end;
end;

procedure TMFtp.Refresh;
var R1, R2: Boolean;
begin
   FTPLastAction := ftplaLIST;

   if FCache then
   begin
      if (LowerCase(FUser) = 'ftp') or (LowerCase(FUser) = 'anonymous') then
      begin
         R1 := LoadFromCache(Server +  '-' + FDirectory + '.cached', FDirectories, FDirectoriesInfo, FCacheE);
         R2 := LoadFromCache(Server +  '-' + FDirectory + '.cachef', FFiles, FFilesInfo, FCacheE);
      end
      else
      begin
         R1 := LoadFromCache(Server + '(' + FUser + ')' + '-' + FDirectory + '.cached', FDirectories, FDirectoriesInfo, FCacheE);
         R2 := LoadFromCache(Server + '(' + FUser + ')' + '-' + FDirectory + '.cachef', FFiles, FFilesInfo, FCacheE);
      end;

      if (R1 = True) and (R2 = True) then
      begin
         FFromCache := True;
         Ready;
         Exit;
      end;
   end;

   if CheckStatus then
   begin
      FFromCache := False;
      SetTransferMode('A', 8);
   end;
end;

procedure TMFtp.Quit;
begin
   if CheckStatus then Proceed('QUIT', 60);
end;

procedure TMFtp.SetUrl;
var S1, S2, RT, TUser, TPass, TServer: String;
    p, TPort: Integer;
begin
   if FBusy then
   begin
      DoFtpInfo(ftpAlreadyBusy, '');
      Exit;
   end;

   {parsing the url line}
   S := Trim(S);
   RT := LowerCase(Copy(S, 1, 6));
   if RT <> 'ftp://' then
   begin
      DoFtpInfo(ftpBadURL, 'The protocol is not supported');
      FBusy := False;
      Exit;
   end
   else
   begin
      S1 := '';
      Delete(S, 1, 6);
      p := Pos('@', S);
      if p > 0 then
      begin
         S1 := Copy(S, 1, p - 1);
         Delete(S, 1, p);
      end;
      p := Pos('/', S);
      if p = 0 then
         S2 := ''
      else
      begin
         S2 := Copy(S, p, 999);
         Delete(S, p, 999);
      end;
      if S1 = '' then
      begin
         if FUser = '' then FUser := 'anonymous';
         if FPass = '' then FPass := '[e-mail]';
         TUser := FUser;
         TPass := FPass;
      end
      else
      begin
         p := Pos(':', S1);
         if p = 0 then
         begin
            DoFtpInfo(ftpBadURL, '');
            FBusy := False;
            Exit;
         end;
         TUser := Copy(S1, 1, p - 1);
         TPass := Copy(S1, p + 1, 999);
      end;
      p := Pos(':', S);
      if p = 0 then
      begin
         TServer := S;
         TPort := 21;
      end
      else
      begin
         TServer := Copy(S, 1, p - 1);
         TPort := StrToInt(Copy(S, p + 1, 999));
      end;
   end;

   FUrl := S2;

   FBusy := True;
   if Assigned(FFtpBusy) then FFtpBusy(Self);
   CallNEvents(12);

   if (FUser = TUser) and (FPass = TPass) and (FServer = TServer)
       and (FPort = TPort) and (ControlLoggedIn) then
   begin
      Step := 200;
      FTPProc('299');
      Exit;
   end;

   FUser := TUser;
   FPass := TPass;
   Server := TServer;
   FPort := TPort;

   if not ControlConnected then
   begin
      URLMode := 2;
      Login;
   end
   else
   begin
      URLMode := 1;
      Proceed('QUIT', 60);
   end;
end;

function TMFtp.GetUrl;
var i: Integer;
begin
   {reformats the url, extra information(port, password etc.) is excluded}
   Result := 'ftp://' + Server + '/';

   if FDirectory = '' then Exit;
   if FDirectory = '/' then Exit;
   if FDirectory[1] = '/' then Delete(FDirectory, 1, 1);

   Result := Result + FDirectory;

   i := Length(Result);
   if Result[i] <> '/' then Result := Result + '/';
end;

procedure TMFtp.Proceed;
var
   data: String;
begin
   data := line + #13#10;
   if Aborted then Exit;
   DoFtpInfo(ftpTraceOut, data);
   while data <> '' do
   begin
      Application.ProcessMessages;
      if Aborted then Exit;
      Delete(data, 1, SendBuf(PChar(@data[1]), Length(data)));
      if CheckError then Exit;
   end;
   Step := n;
end;

procedure TMFtp.DidConnect;
begin
   if CheckError then Exit;
   Step := 0;
   DoFtpInfo(ftpServerConnected, Address);
   ControlConnected := True;
   PartialLine := '';
   OnHold := False;
end;

procedure TMFtp.TimedOut;
begin
   errs := 'Connection timed out';
   FatalError(ftpConnectTimeOut);
end;

procedure TMFtp.DoDisconnect;
var ST: LongWord;
   procedure RealDoDisconnect;
   begin
      ControlConnected := False;
      Step := 100;
      DoFTPInfo(ftpServerDisconnected, 'Disconnected');
      PostMessage(Handle, FTP_AVAILABLE, 0, 0);
      FtpLastAction := ftplaNone;
      Ready;
   end;
begin
   if FDBusy then Exit;

   if (not ControlLoggedIn) and (FRemain >= 0) and (FError <> ftpNone) then
   begin
      DoFTPInfo(ftpRetrying, 'Retrying...');
      FDBusy := True;
      SRetry := False;
      if FRetryI > 0 then
      begin
         ST := GetTickCount;
         while GetTickCount - ST < FRetryI * 1000 do
         begin
            if SRetry then
               Break
            else
               Application.ProcessMessages;
         end;
      end;
      if not SRetry then
      begin
         LoginMain;
         Exit;
      end;
   end;
   RealDoDisconnect;
end;

procedure TMFtp.DoRead;
var
   linein, newline: String;
   el: Integer;
begin
   if OnHold then Exit;
   if Aborted then Exit;
   while True do
   begin
      if Aborted then Exit;
      linein := RecvText;
      if CheckError then Exit;
      DoFtpInfo(ftpTraceIn, linein);
      if Length(linein) = 0 then Exit;
      linein := PartialLine + linein;

      repeat
         el := Pos(#13 + #10, linein);
         if el <> 0 then
         begin
            newline := Copy(linein, 1, el - 1);
            Delete(linein, 1, el + 1);
            OnHold := True;
            FtpProc(newline);
            OnHold := False;
            if Aborted then Exit;
         end;
      until el = 0;
      PartialLine := linein;
   end;
end;

procedure TMFtp.FatalError;
begin
   if Aborted then Exit;

   FError := e;
   DoFtpError(e);