comparison lisp/net/ange-ftp.el @ 65810:0534e10b621e

Use with-current-buffer. (ange-ftp-insert-directory): Do not follow symlinks any more.

65809:f528ccbc5de9

	     (not (equal (nth 5 attr) ange-ftp-netrc-modtime)))	; file changed
	(save-match-data
	  (if (or ange-ftp-disable-netrc-security-check
		  (and (eq (nth 2 attr) (user-uid)) ; Same uids.
		       (string-match ".r..------" (nth 8 attr))))
	      (save-excursion
		;; we are cheating a bit here.  I'm trying to do the equivalent
		;; of find-file on the .netrc file, but then nuke it afterwards.
		;; with the bit of logic below we should be able to have
		;; encrypted .netrc files.
		(set-buffer (generate-new-buffer "*ftp-.netrc*"))
		(ange-ftp-real-insert-file-contents file)
		(setq buffer-file-name file)
		(setq default-directory (file-name-directory file))
		(normal-mode t)
		(run-hooks 'find-file-hook)

  (interactive "bKill FTP process associated with buffer: ")
  (if (null buffer)
      (setq buffer (current-buffer))
    (setq buffer (get-buffer buffer)))
  (let ((file (or (buffer-file-name buffer)
		  (save-excursion (set-buffer buffer) default-directory))))
    (if file
	(let ((parsed (ange-ftp-ftp-name (expand-file-name file))))
	  (if parsed
	      (let ((host (nth 0 parsed))
		    (user (nth 1 parsed)))

  "Set the size of the next FTP transfer in bytes."
  (let ((proc (ange-ftp-get-process host user)))
    (if proc
	(let ((buf (process-buffer proc)))
	  (if buf
	      (save-excursion
		(set-buffer buf)
		(setq ange-ftp-xfer-size
		      ;; For very large files, BYTES can be a float.
		      (if (integerp bytes)
			  (ash bytes -10)
			(/ bytes 1024)))))))))

(defun ange-ftp-gwp-sentinel (proc str)
  (setq ange-ftp-gwp-running nil))

(defun ange-ftp-gwp-filter (proc str)
  (comint-output-filter proc str)
  (save-excursion
    (set-buffer (process-buffer proc))
    ;; Replace STR by the result of the comint processing.
    (setq str (buffer-substring comint-last-output-start (process-mark proc))))
  (cond ((string-match "login: *$" str)
	 (process-send-string proc
                              (concat

	    (proc (let ((process-connection-type t))
		    (start-process " *nslookup*" " *nslookup*"
				   ange-ftp-nslookup-program host)))
	    (res host))
	(set-process-query-on-exit-flag proc nil)
	(save-excursion
	  (set-buffer (process-buffer proc))
	  (while (memq (process-status proc) '(run open))
	    (accept-process-output proc))
	  (goto-char (point-min))
	  (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t)
	      (setq res (match-string 1)))

    ;; Can anyone find a fix for that?
    (let ((process-connection-type t)
	  ;; Copy this so we don't alter it permanently.
	  (process-environment (copy-tree process-environment))
	  (buffer (get-buffer-create name)))
      (save-excursion
	(set-buffer buffer)
	(internal-ange-ftp-mode))
      ;; This tells GNU ftp not to output any fancy escape sequences.
      (setenv "TERM" "dumb")
      (if use-gateway
	  (if ange-ftp-gateway-program-interactive

	    (setq proc (apply 'start-process name name
			      (append (list ange-ftp-gateway-program
					    ange-ftp-gateway-host)
				      args))))
	(setq proc (apply 'start-process name name args))))
    (save-excursion
      (set-buffer (process-buffer proc))
      (goto-char (point-max))
      (set-marker (process-mark proc) (point)))
    (set-process-query-on-exit-flag proc nil)
    (set-process-sentinel proc 'ange-ftp-process-sentinel)
    (set-process-filter proc 'ange-ftp-process-filter)

  "[hH]ash mark [^0-9]*\\([0-9]+\\)"
  "*Regexp matching the FTP client's output upon doing a HASH command.")

(defun ange-ftp-guess-hash-mark-size (proc)
  (if ange-ftp-send-hash
      (save-excursion
	(set-buffer (process-buffer proc))
	(let* ((status (ange-ftp-raw-send-cmd proc "hash"))
	       (line (cdr status)))
	  (save-match-data
	    (if (string-match ange-ftp-hash-mark-msgs line)
		(let ((size (string-to-number (match-string 1 line))))

      ;; be happy.)
      (and (eq host-type 'unix)
	   (string-match "/\\'" cmd1)
	   (not (string-match "R" cmd3))
	   (setq cmd1 (concat cmd1 ".")))

      ;; If the dir name contains a space, some ftp servers will
      ;; refuse to list it.  We instead change directory to the
      ;; directory in question and ls ".".
      (when (string-match " " cmd1)

				       user
				       lscmd
				       (format "Listing %s"
					       (ange-ftp-abbreviate-filename
						ange-ftp-this-file)))))
		    (save-excursion
		      (set-buffer (get-buffer-create
				   ange-ftp-data-buffer-name))
		      (erase-buffer)
		      (if (ange-ftp-real-file-readable-p temp)
			  (ange-ftp-real-insert-file-contents temp)
			(sleep-for ange-ftp-retry-time)
					;wait for file to possibly appear

(defun ange-ftp-set-binary-mode (host user)
  "Tell the ftp process for the given HOST & USER to switch to binary mode."
  (let ((result (ange-ftp-send-cmd host user '(type "binary"))))
    (if (not (car result))
	(ange-ftp-error host user (concat "BINARY failed: " (cdr result)))
      (save-excursion
	(set-buffer (process-buffer (ange-ftp-get-process host user)))
	(and ange-ftp-binary-hash-mark-size
	     (setq ange-ftp-hash-mark-unit
		   (ash ange-ftp-binary-hash-mark-size -4)))))))

(defun ange-ftp-set-ascii-mode (host user)
  "Tell the ftp process for the given HOST & USER to switch to ascii mode."
  (let ((result (ange-ftp-send-cmd host user '(type "ascii"))))
    (if (not (car result))
	(ange-ftp-error host user (concat "ASCII failed: " (cdr result)))
      (save-excursion
	(set-buffer (process-buffer (ange-ftp-get-process host user)))
	(and ange-ftp-ascii-hash-mark-size
	     (setq ange-ftp-hash-mark-unit
		   (ash ange-ftp-ascii-hash-mark-size -4)))))))

(defun ange-ftp-cd (host user dir &optional noerror)

						    (or visit 'quiet))
			(setq coding-system-used last-coding-system-used))
		    ;; cleanup forms
		    (setq coding-system-used last-coding-system-used)
		    (setq buffer-file-name filename)
		    (set-buffer-modified-p mod-p)))
		(if binary
		    (ange-ftp-set-binary-mode host user))

		;; tell the process filter what size the transfer will be.
		(let ((attr (file-attributes temp)))

;;     (process-kill-without-query proc)
;;     (with-current-buffer (process-buffer proc)
;;       (set (make-local-variable 'copy-cont) cont))))
;;
;; (defun ange-ftp-copy-file-locally-sentinel (proc status)
;;   (save-excursion
;;     (set-buffer (process-buffer proc))
;;     (let ((cont copy-cont)
;; 	  (result (buffer-string)))
;;       (unwind-protect
;; 	  (if (and (string-equal status "finished\n")
;; 		   (zerop (length result)))

;; `ange-ftp-ls' handles this.

(defun ange-ftp-insert-directory (file switches &optional wildcard full)
  (if (not (ange-ftp-ftp-name (expand-file-name file)))
      (ange-ftp-real-insert-directory file switches wildcard full)
    ;; Follow symlinks.
    (let (tem)
      (while (and (not wildcard)
                  (stringp (setq tem (file-symlink-p
                                      (directory-file-name file)))))
        (setq file
              (ange-ftp-expand-symlink
               tem (file-name-directory (directory-file-name file))))))
    (insert
     (cond
      (wildcard
       (let ((default-directory (file-name-directory file)))
         (ange-ftp-ls (file-name-nondirectory file) switches nil nil t)))

;;(defun ange-ftp-dcf-1 (file-creator operation fn-list name-constructor
;;		       target marker-char buffer overwrite-query
;;		       overwrite-backup-query failures skipped
;;		       success-count total)
;;  (let ((old-buf (current-buffer)))
;;    (unwind-protect
;;	(progn
;;	  (set-buffer buffer)
;;	  (if (null fn-list)
;;	      (ange-ftp-dcf-3 failures operation total skipped
;;			      success-count buffer)

;;	    (let* ((from (car fn-list))

;;				     overwrite
;;				     overwrite-confirmed
;;				     overwrite-query
;;				     overwrite-backup-query
;;				     failures skipped success-count
;;				     total))))))))
;;      (set-buffer old-buf))))

;;(defun ange-ftp-dcf-2 (result line err
;;			      file-creator operation fn-list
;;			      name-constructor
;;			      target

;;			      overwrite-confirmed
;;			      overwrite-query
;;			      overwrite-backup-query
;;			      failures skipped success-count
;;			      total)
;;  (let ((old-buf (current-buffer)))
;;    (unwind-protect
;;	(progn
;;	  (set-buffer buffer)
;;	  (if (or err (not result))
;;	      (progn
;;		(setq failures (cons (dired-make-relative from) failures))
;;		(dired-log "%s `%s' to `%s' failed:\n%s\n"
;;			   operation from to (or err line)))

;;			  marker-char
;;			  buffer
;;			  overwrite-query
;;			  overwrite-backup-query
;;			  failures skipped success-count
;;			  total))
;;      (set-buffer old-buf))))

;;(defun ange-ftp-dcf-3 (failures operation total skipped success-count
;;				buffer)
;;  (let ((old-buf (current-buffer)))
;;    (unwind-protect
;;	(progn
;;	  (set-buffer buffer)
;;	  (cond
;;	   (failures
;;	    (dired-log-summary
;;	     (message "%s failed for %d of %d file%s %s"
;;		      operation (length failures) total

;;		      operation (length skipped) total
;;		      (dired-plural-s total) skipped)))
;;	   (t
;;	    (message "%s: %s file%s."
;;		     operation success-count (dired-plural-s success-count))))
;;	  (dired-move-to-filename))
;;      (set-buffer old-buf))))

;;;; -----------------------------------------------
;;;; Unix Descriptive Listing (dl) Support
;;;; -----------------------------------------------

65810:0534e10b621e

	     (not (equal (nth 5 attr) ange-ftp-netrc-modtime)))	; file changed
	(save-match-data
	  (if (or ange-ftp-disable-netrc-security-check
		  (and (eq (nth 2 attr) (user-uid)) ; Same uids.
		       (string-match ".r..------" (nth 8 attr))))
	      (with-current-buffer
		;; we are cheating a bit here.  I'm trying to do the equivalent
		;; of find-file on the .netrc file, but then nuke it afterwards.
		;; with the bit of logic below we should be able to have
		;; encrypted .netrc files.
                  (generate-new-buffer "*ftp-.netrc*")
		(ange-ftp-real-insert-file-contents file)
		(setq buffer-file-name file)
		(setq default-directory (file-name-directory file))
		(normal-mode t)
		(run-hooks 'find-file-hook)

  (interactive "bKill FTP process associated with buffer: ")
  (if (null buffer)
      (setq buffer (current-buffer))
    (setq buffer (get-buffer buffer)))
  (let ((file (or (buffer-file-name buffer)
		  (with-current-buffer buffer default-directory))))
    (if file
	(let ((parsed (ange-ftp-ftp-name (expand-file-name file))))
	  (if parsed
	      (let ((host (nth 0 parsed))
		    (user (nth 1 parsed)))

  "Set the size of the next FTP transfer in bytes."
  (let ((proc (ange-ftp-get-process host user)))
    (if proc
	(let ((buf (process-buffer proc)))
	  (if buf
	      (with-current-buffer buf
		(setq ange-ftp-xfer-size
		      ;; For very large files, BYTES can be a float.
		      (if (integerp bytes)
			  (ash bytes -10)
			(/ bytes 1024)))))))))

(defun ange-ftp-gwp-sentinel (proc str)
  (setq ange-ftp-gwp-running nil))

(defun ange-ftp-gwp-filter (proc str)
  (comint-output-filter proc str)
  (with-current-buffer (process-buffer proc)
    ;; Replace STR by the result of the comint processing.
    (setq str (buffer-substring comint-last-output-start (process-mark proc))))
  (cond ((string-match "login: *$" str)
	 (process-send-string proc
                              (concat

	    (proc (let ((process-connection-type t))
		    (start-process " *nslookup*" " *nslookup*"
				   ange-ftp-nslookup-program host)))
	    (res host))
	(set-process-query-on-exit-flag proc nil)
	(with-current-buffer (process-buffer proc)
	  (while (memq (process-status proc) '(run open))
	    (accept-process-output proc))
	  (goto-char (point-min))
	  (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t)
	      (setq res (match-string 1)))

    ;; Can anyone find a fix for that?
    (let ((process-connection-type t)
	  ;; Copy this so we don't alter it permanently.
	  (process-environment (copy-tree process-environment))
	  (buffer (get-buffer-create name)))
      (with-current-buffer buffer
	(internal-ange-ftp-mode))
      ;; This tells GNU ftp not to output any fancy escape sequences.
      (setenv "TERM" "dumb")
      (if use-gateway
	  (if ange-ftp-gateway-program-interactive

	    (setq proc (apply 'start-process name name
			      (append (list ange-ftp-gateway-program
					    ange-ftp-gateway-host)
				      args))))
	(setq proc (apply 'start-process name name args))))
    (with-current-buffer (process-buffer proc)
      (goto-char (point-max))
      (set-marker (process-mark proc) (point)))
    (set-process-query-on-exit-flag proc nil)
    (set-process-sentinel proc 'ange-ftp-process-sentinel)
    (set-process-filter proc 'ange-ftp-process-filter)

  "[hH]ash mark [^0-9]*\\([0-9]+\\)"
  "*Regexp matching the FTP client's output upon doing a HASH command.")

(defun ange-ftp-guess-hash-mark-size (proc)
  (if ange-ftp-send-hash
      (with-current-buffer (process-buffer proc)
	(let* ((status (ange-ftp-raw-send-cmd proc "hash"))
	       (line (cdr status)))
	  (save-match-data
	    (if (string-match ange-ftp-hash-mark-msgs line)
		(let ((size (string-to-number (match-string 1 line))))

      ;; be happy.)
      (and (eq host-type 'unix)
	   (string-match "/\\'" cmd1)
	   (not (string-match "R" cmd3))
	   (setq cmd1 (concat cmd1 ".")))

      ;; Using "ls -flags foo" has several problems:
      ;; - if foo is a symlink, we may get a single line showing the symlink
      ;;   rather than the listing of the directory it points to.
      ;; - if "foo" has spaces, the parsing of the command may be done wrong.
      ;; - some version of netbsd's ftpd only accept a single argument after
      ;;   `ls', which can either be the directory or the flags.
      ;; So to work around those problems, we use "cd foo; ls -flags".

      ;; If the dir name contains a space, some ftp servers will
      ;; refuse to list it.  We instead change directory to the
      ;; directory in question and ls ".".
      (when (string-match " " cmd1)

				       user
				       lscmd
				       (format "Listing %s"
					       (ange-ftp-abbreviate-filename
						ange-ftp-this-file)))))
		    (with-current-buffer (get-buffer-create
                                          ange-ftp-data-buffer-name))
		      (erase-buffer)
		      (if (ange-ftp-real-file-readable-p temp)
			  (ange-ftp-real-insert-file-contents temp)
			(sleep-for ange-ftp-retry-time)
					;wait for file to possibly appear

(defun ange-ftp-set-binary-mode (host user)
  "Tell the ftp process for the given HOST & USER to switch to binary mode."
  (let ((result (ange-ftp-send-cmd host user '(type "binary"))))
    (if (not (car result))
	(ange-ftp-error host user (concat "BINARY failed: " (cdr result)))
      (with-current-buffer (process-buffer (ange-ftp-get-process host user))
	(and ange-ftp-binary-hash-mark-size
	     (setq ange-ftp-hash-mark-unit
		   (ash ange-ftp-binary-hash-mark-size -4)))))))

(defun ange-ftp-set-ascii-mode (host user)
  "Tell the ftp process for the given HOST & USER to switch to ascii mode."
  (let ((result (ange-ftp-send-cmd host user '(type "ascii"))))
    (if (not (car result))
	(ange-ftp-error host user (concat "ASCII failed: " (cdr result)))
      (with-current-buffer (process-buffer (ange-ftp-get-process host user))
	(and ange-ftp-ascii-hash-mark-size
	     (setq ange-ftp-hash-mark-unit
		   (ash ange-ftp-ascii-hash-mark-size -4)))))))

(defun ange-ftp-cd (host user dir &optional noerror)

						    (or visit 'quiet))
			(setq coding-system-used last-coding-system-used))
		    ;; cleanup forms
		    (setq coding-system-used last-coding-system-used)
		    (setq buffer-file-name filename)
		    (restore-buffer-modified-p mod-p)))
		(if binary
		    (ange-ftp-set-binary-mode host user))

		;; tell the process filter what size the transfer will be.
		(let ((attr (file-attributes temp)))

;;     (process-kill-without-query proc)
;;     (with-current-buffer (process-buffer proc)
;;       (set (make-local-variable 'copy-cont) cont))))
;;
;; (defun ange-ftp-copy-file-locally-sentinel (proc status)
;;   (with-current-buffer (process-buffer proc)
;;     (let ((cont copy-cont)
;; 	  (result (buffer-string)))
;;       (unwind-protect
;; 	  (if (and (string-equal status "finished\n")
;; 		   (zerop (length result)))

;; `ange-ftp-ls' handles this.

(defun ange-ftp-insert-directory (file switches &optional wildcard full)
  (if (not (ange-ftp-ftp-name (expand-file-name file)))
      (ange-ftp-real-insert-directory file switches wildcard full)
    ;; We used to follow symlinks on `file' here.  Apparently it was done
    ;; because some FTP servers react to "ls foo" by listing the symlink foo
    ;; rather than the directory it points to.  Now that ange-ftp-ls uses
    ;; "cd foo; ls" instead, this is not necesssary any more.
    (insert
     (cond
      (wildcard
       (let ((default-directory (file-name-directory file)))
         (ange-ftp-ls (file-name-nondirectory file) switches nil nil t)))

;;(defun ange-ftp-dcf-1 (file-creator operation fn-list name-constructor
;;		       target marker-char buffer overwrite-query
;;		       overwrite-backup-query failures skipped
;;		       success-count total)
;;  (with-current-buffer buffer
;;	  (if (null fn-list)
;;	      (ange-ftp-dcf-3 failures operation total skipped
;;			      success-count buffer)

;;	    (let* ((from (car fn-list))

;;				     overwrite
;;				     overwrite-confirmed
;;				     overwrite-query
;;				     overwrite-backup-query
;;				     failures skipped success-count
;;				     total)))))))))

;;(defun ange-ftp-dcf-2 (result line err
;;			      file-creator operation fn-list
;;			      name-constructor
;;			      target

;;			      overwrite-confirmed
;;			      overwrite-query
;;			      overwrite-backup-query
;;			      failures skipped success-count
;;			      total)
;;  (with-current-buffer buffer
;;	  (if (or err (not result))
;;	      (progn
;;		(setq failures (cons (dired-make-relative from) failures))
;;		(dired-log "%s `%s' to `%s' failed:\n%s\n"
;;			   operation from to (or err line)))

;;			  marker-char
;;			  buffer
;;			  overwrite-query
;;			  overwrite-backup-query
;;			  failures skipped success-count
;;			  total)))

;;(defun ange-ftp-dcf-3 (failures operation total skipped success-count
;;				buffer)
;;  (with-current-buffer buffer
;;	  (cond
;;	   (failures
;;	    (dired-log-summary
;;	     (message "%s failed for %d of %d file%s %s"
;;		      operation (length failures) total

;;		      operation (length skipped) total
;;		      (dired-plural-s total) skipped)))
;;	   (t
;;	    (message "%s: %s file%s."
;;		     operation success-count (dired-plural-s success-count))))
;;	  (dired-move-to-filename)))

;;;; -----------------------------------------------
;;;; Unix Descriptive Listing (dl) Support
;;;; -----------------------------------------------