ftp.pas

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

   FList.Free;
   FFList.Free;
   FDList.Free;
   FFiles.Free;
   FDirectories.Free;

   FDirectoriesInfo.Free;
   FFilesInfo.Free;
   NTimer.Free;
   inherited Destroy;
end;

procedure TMFtp.UserMessageHandler;
var IndexFile: String;
begin
   case Message.Msg of
      FTP_AVAILABLE:
      begin
         FBusy := False;
         NTimer.Enabled := False;
         ControlLoggedIn := False;

         if Assigned(FFtpQuit) then FFtpQuit(Self);
         CallNEvents(8);

         if UrlMode = 1 then Login;
      end;
//    FTP_ERROR: if Assigned(FOnError) then FOnError(Self, FtpError(Message.WParam), 'Error');
      FTP_READY:
      begin
         FBusy := False;
         NTimer.Enabled := True;

         if Assigned(FOnReady) then FOnReady(Self);
         CallNEvents(9);

         if TransferAborted then
         begin
            DataSocket.Disconnect;
            ListeningSocket.Disconnect;
            TransferAborted := False;
         end;
         case FtpLastAction of
            ftplaLogin:
            begin
               FtpLastAction := ftplaNone;
               ControlLoggedIn := True;
               if Assigned(FLoggedIn) then FloggedIn(Self);
               CallNEvents(11);
            end;
            ftplaCDUP, ftplaCWD:
            begin
               FtpLastAction := ftplaNone;
               if Assigned(FDirectoryChanged) then FDirectoryChanged(Self);
               CallNEvents(1);
            end;
            ftplaMKD:
            begin
               FtpLastAction := ftplaNone;
               if Assigned(FDirectoryCreated) then FDirectoryCreated(Self);
               CallNEvents(2);
            end;
            ftplaRMD:
            begin
               FtpLastAction := ftplaNone;
               if Assigned(FDirectoryDeleted) then FDirectoryDeleted(Self);
               CallNEvents(3);
            end;
            ftplaRM:
            begin
               FtpLastAction := ftplaNone;
               if Assigned(FFileDeleted) then FFileDeleted(Self);
               CallNEvents(4);
            end;
            ftplaGETIndexFile:
            begin
               FtpLastAction := ftplaNone;
               if ParseIndexFile(FIFile, FDirectories, FFiles,
                                           FDirectoriesInfo, FFilesInfo) then
               begin
                  UpdateCache;

                  if Assigned(FIndexFileReceived) then FIndexFileReceived(Self);
                  CallNEvents(14);
               end;
            end;
            ftplaGET:
            begin
               FtpLastAction := ftplaNone;
               if Assigned(FFileReceived) then FFileReceived(Self);
               CallNEvents(5);
            end;
            ftplaPUT:
            begin
               FtpLastAction := ftplaNone;
               if Assigned(FFileStored) then FFileStored(Self);
               CallNEvents(7);
            end;
            ftplaLIST:
            begin
               FtpLastAction := ftplaNone;
               if Assigned(FListingDone) then FListingDone(Self);
               CallNEvents(10);

               if not FFromCache then
               begin
                  if Assigned(NeedInfo) then NeedInfo(Self, niIndexFile, IndexFile);
                  if Trim(IndexFile) <> '' then LoadIndexFile(IndexFile);
               end;
            end;
            ftplaREN:
            begin
               FtpLastAction := ftplaNone;
               if Assigned(FFileRenamed) then FFileRenamed(Self);
               CallNEvents(6);
            end;
         end;
      end;
   end;
end;

procedure TMFtp.DoFtpInfo;
var hs: Integer;
    S: String;
begin
   if add = '' then
   begin
      case info of
         ftpAlreadyBusy:
            S := 'The component is busy doing something';
         ftpBadURL:
            S := 'Invalid sytax';
         ftpLoggedIn:
            S := 'Logged in';
         ftpNotSupportResume:
            S := 'This site cannot resume broken downloads/uploads';
         ftpPermissionDenied:
            S := 'Access denied or file not found';
         ftpServerDisconnected:
            S := 'Not connected to the server';
         ftpSizeDifferent:
            S := 'The size of Source/Destination lists don'#39't equal';
      end;
   end
   else
   begin
      if (info = ftpTraceOut) and (Copy(add, 1, 5) = 'PASS ') then
      begin
         S := 'PASS (want to know) :-P'#13#10;
      end
      else
      begin
         S := add;
      end;
   end;

   if Assigned(FtpInfoEvt) then FtpInfoEvt(Self, info, S);
   for hs := 1 to MAX_HANDLERS do
      if Assigned(NOnFtpInfo[hs]) then NOnFtpInfo[hs](Self, info, S);
end;

procedure TMFtp.DoFtpError;
var hs: Integer;
begin
   FSuccess := False;
   FError := e;
// PostMessage(Handle,FTP_ERROR,Ord(e), 0);
   if Assigned(FOnError) then FOnError(Self, e, errs);
   for hs := 1 to MAX_HANDLERS do
      if Assigned(NOnFtpError[hs]) then NOnFtpError[hs](Self, e, errs);
end;

procedure TMFtp.Ready;
begin
   PostMessage(Handle, FTP_READY, 0, 0);
end;

procedure TMFtp.Login;
begin
   FRemain := FRetries;
   FBusy := False;
   ControlLoggedIn := False;

   LoginMain;
end;

procedure TMFtp.LoginMain;
var i: Integer;
    s: String;
begin
   FDBusy := False;
   if FBusy then
   begin
      DoFtpInfo(ftpAlreadyBusy, '');
      Exit;
   end;

   Step := 0;
   LastError := 0;
   FDirectory := '';
   Response := '';
   FError := FtpNone;
   FSuccess := True;
   Intermediate := False;
   for i := 1 to 3 do Supports[i] := True;


   Dec(FRemain);
   ReCreateTCPSocket;

   if Trim(FProxyServer) = '' then FProxyType := proxyNone else
   if FProxyType <> proxyNone then
   begin
      FtpServer := Server;
      FtpPort := Port;
      Server := FProxyServer;
      Port := FProxyPort;
   end;

   if Trim(Server) = '' then
   begin
      if Assigned(NeedInfo) then NeedInfo(Self, niHost, s);
      s := Trim(s);
      if s = '' then
      begin
         DoFtpError(ftpNoServer);
         Ready;
         Exit;
      end;
      SetServer(s);
   end;

   if Port = 0 then Port := 21;

   if Address <> '' then FillAddress(Address)
   else
   begin
      DoFtpInfo(ftpResolvingAddress, Host);
      LookupName(Host);
      CheckError;
      Exit;
   end;
   FillPort(Port);
   Connect;
   CheckError;
end;

procedure TMFtp.LookupNameDone;
begin
   if CheckError then Exit;
   FillName;
   FillPort(Port);
   Address := GetAddressString;
   DoFtpInfo(ftpAddressResolved, Address);
   Connect;
   CheckError;
end;

procedure TMFtp.UpdateCache;
begin
   if (LowerCase(FUser) = 'ftp') or (LowerCase(FUser) = 'anonymous') then
   begin
      SaveToCache(Server +  '-' + FDirectory + '.cached', FDirectories, FDirectoriesInfo);
      SaveToCache(Server +  '-' + FDirectory + '.cachef', FFiles, FFilesInfo);
   end
   else
   begin
      SaveToCache(Server + '(' + FUser + ')' + '-' + FDirectory + '.cached', FDirectories, FDirectoriesInfo);
      SaveToCache(Server + '(' + FUser + ')' + '-' + FDirectory + '.cachef', FFiles, FFilesInfo);
   end;
end;

{===== Directory/File  managemenet routines =====}
procedure TMFtp.ChangeDirectory;
begin
   if CheckStatus then
   begin
      FtpLastAction := ftplaCWD;
      Proceed('CWD ' + name, 51);
   end;
end;

procedure TMFtp.ChangeToParentDirectory;
begin
   if CheckStatus then
   begin
      FtpLastAction := ftplaCDUP;
      Proceed('CDUP', 51);
   end;
end;

procedure TMFtp.CreateDirectory(dir: String);
begin
   if CheckStatus then
   begin
      FTPLastAction := ftplaMKD;
      Proceed('MKD ' + dir, 50);
   end;
end;  

{$ifdef HAVE_OVERLOAD}
procedure TMFtp.CreateDirectory(dirlist: TStrings);
{$else}
procedure TMFtp.CreateDirectories(dirlist: TStrings);
{$endif}
var dir: String;
begin
   if Assigned(dirlist) and CheckStatus then
   begin
      if dirlist.Count > 0 then
      begin
         FTPLastAction := ftplaMKD;
         FDList.Assign(dirlist);
         dir := FDList[0];
         FDList.Delete(0);
         Proceed('MKD ' + dir, 300);
      end
      else
      begin
         Ready;
      end;
   end;
end;

procedure TMFtp.DeleteDirectory(dir: String);
begin
   if (dir <> '') and (CheckStatus) then
   begin
      FTPLastAction := ftplaRMD;
      OprDir := dir;
      Proceed('RMD ' + dir, 312);
   end;
end;

{$ifdef HAVE_OVERLOAD}
procedure TMFtp.DeleteDirectory(dirlist: TStrings);
{$else}
procedure TMFtp.DeleteDirectories(dirlist: TStrings);
{$endif}
var dir: String;
begin
   if Assigned(dirlist) and CheckStatus then
   begin
      if dirlist.Count > 0 then
      begin
         FTPLastAction := ftplaRMD;
         FDList.Assign(dirlist);
         dir := FDList[0];
         OprDir := dir;
         FDList.Delete(0);
         Proceed('RMD ' + dir, 310);
      end
      else
      begin
         Ready;
      end;
   end;
end;

procedure TMFtp.DeleteFile(filename: String);
begin
   if (filename <> '') and (CheckStatus) then
   begin
      FTPLastAction := ftplaRM;
      Proceed('DELE ' + filename, 50);
   end;
end;

{$ifdef HAVE_OVERLOAD}
procedure TMFtp.DeleteFile(filelist: TStrings);
{$else}
procedure TMFtp.DeleteFiles(filelist: TStrings);
{$endif}
var filename: String;
begin
   if Assigned(filelist) and CheckStatus then
   begin
      if filelist.Count > 0 then
      begin
         FTPLastAction := ftplaRM;
         FFList.Assign(filelist);
         filename := FFList[0];
         FFList.Delete(0);
         Proceed('DELE ' + filename, 301);
      end
      else
      begin
         Ready;
      end;
   end;
end;

procedure TMFtp.MoveFile(filename, newdir: String);
var i, j: Integer;
    realname: String;
begin
   i := Length(filename);
   realname := filename;
   for j := i downto 1 do
   begin
      if filename[j] = '/' then
      begin
         realname := Copy(filename, j + 1, 999);
         Break;
      end;
   end;
   i := Length(newdir);
   if (newdir[i] <> '/') then newdir := newdir + '/';
   RenameFile(filename, newdir + realname);
end;

{$ifdef HAVE_OVERLOAD}
procedure TMFtp.MoveFile(filelist, dirlist: TStrings);
{$else}
procedure TMFtp.MoveFiles(filelist, dirlist: TStrings);
{$endif}
var S, D: TStrings;
    i, j, k: Integer;
    realname: String;
begin
   S := TStringList.Create;
   D := TStringList.Create;

   if CheckStatus then
   begin
      if Assigned(filelist) and Assigned(dirlist) then
      begin
         if filelist.Count = dirlist.count then
         begin
            if filelist.Count > 0 then
            begin
               for k := 0 to filelist.Count - 1 do
               begin
                  i := Length(filelist[k]);
                  realname := filelist[k];
                  for j := i downto 1 do
                  begin
                     if filelist[k][j] = '/' then
                     begin
                        realname := Copy(filelist[k], j + 1, 999);
                        Break;
                     end;
                  end;
                  i := Length(dirlist[k]);
                  if (dirlist[k][i] <> '/') then dirlist[k] := dirlist[k] + '/';
                  S.Add(filelist[k]);
                  D.Add(dirlist[k] + realname);
               end;