comparison lisp/ange-ftp.el @ 22278:7a9f75f6e065

(ange-ftp-expand-file-name): Set default to default-directory if nil. Check whether default starts with a drive specifier on windows-nt, as well as name, and call real function if so. Remove code to strip prefix before // or /~ since `expand-file-name' itself no longer does that. (ange-ftp-expand-dir): Use `grep-null-device' instead of "/dev/null", which is incorrect on windows-nt. (ange-ftp-file-name-all-completions): Fix root directory regexp for windows-nt. (ange-ftp-start-process): On windows-nt, always send a "help foo" command to ensure the ftp process produces some output, and force the process to use raw-text-dos decoding. (ange-ftp-canonize-filename): On windows-nt, strip drive specifier from expanded remote name. (ange-ftp-write-region): Allow binary transfer on windows-nt if remote host type is unix. Ensure `last-coding-system-used' is given an appropriate value, so that basic-save-buffer isn't confused by the coding used with the ftp process. (ange-ftp-insert-file-contents): Ditto. (ange-ftp-copy-file-internal): Ditto. (ange-ftp-real-expand-file-name): Use standard definition on windows-nt. (ange-ftp-real-expand-file-name-actual): Remove obsolete function. (ange-ftp-disable-netrc-security-check): Make default value be t on windows-nt. (ange-ftp-start-process): Undo previous change.

22277:cc85ea3f54cc

(defcustom ange-ftp-netrc-filename "~/.netrc"
  "*File in .netrc format to search for passwords."
  :group 'ange-ftp
  :type 'file)

(defcustom ange-ftp-disable-netrc-security-check nil
  "*If non-nil avoid checking permissions on the .netrc file."
  :group 'ange-ftp
  :type 'boolean)

(defcustom ange-ftp-default-user nil

      (goto-char (point-max))
      (set-marker (process-mark proc) (point)))
    (process-kill-without-query proc)
    (set-process-sentinel proc (function ange-ftp-process-sentinel))
    (set-process-filter proc (function ange-ftp-process-filter))
    ;; wait for ftp startup message
    (if (not (eq system-type 'windows-nt))
	(accept-process-output proc)
      ;; On Windows, the standard ftp client behaves a little oddly,
      ;; initially buffering its output (because stdin/out are pipe
      ;; handles).  As a result, the startup message doesn't appear
      ;; until enough output is generated to flush stdout, so a plain
      ;; accept-process-output call at this point would hang
      ;; indefinitely.  So if nothing appears within 2 seconds, we try
      ;; sending an innocuous command ("help foo") that forces some
      ;; output.  Curiously, once we start sending normal commands, the
      ;; output no longer appears to be buffered, and everything works
      ;; correctly (or at least appears to!).
      (if (accept-process-output proc 2)
	  nil
 	(process-send-string proc "help foo\n")
	(accept-process-output proc)))
    proc))

(put 'internal-ange-ftp-mode 'mode-class 'special)

(defun internal-ange-ftp-mode ()

	   (not (eq host-type 'unix))
	   (let* ((ange-ftp-good-msgs (concat ange-ftp-expand-dir-regexp
					      "\\|"
					      ange-ftp-good-msgs))
		  (result (ange-ftp-send-cmd host user
					     (list 'get dir "/dev/null")
					     (format "expanding %s" dir)))
		  (line (cdr result)))
	     (setq res
		   (if (string-match ange-ftp-expand-dir-regexp line)
		       (substring line 

	  
	  ;; If name starts with //, preserve that, for apollo system.
	  (if (not (string-match "^//" name))
	      (progn
		(setq name (ange-ftp-real-expand-file-name name))

		(if (string-match "^//" name)
		    (setq name (substring name 1)))))
	  
	  ;; Now substitute the expanded name back into the overall filename.
	  (ange-ftp-replace-name-component n name))

	 (ange-ftp-real-file-name-directory n))))))

(defun ange-ftp-expand-file-name (name &optional default)
  "Documented as original."
  (save-match-data
    (if (eq (string-to-char name) ?/)
	(while (cond ((string-match "[^:]+//" name) ;don't upset Apollo users
		      (setq name (substring name (1- (match-end 0)))))
		     ((string-match "/~" name)
		      (setq name (substring name (1- (match-end 0))))))))
    (cond ((eq (string-to-char name) ?~)
	   (ange-ftp-real-expand-file-name name))
	  ((eq (string-to-char name) ?/)
	   (ange-ftp-canonize-filename name))
	  ((and (eq system-type 'windows-nt) (string-match "^[a-zA-Z]:" name))
	   name) ; when on local drive, return it as-is
	  ((zerop (length name))
	   (ange-ftp-canonize-filename (or default default-directory)))
	  ((ange-ftp-canonize-filename
	    (concat (file-name-as-directory (or default default-directory))
		    name))))))

;;; These are problems--they are currently not enabled.

(defvar ange-ftp-file-name-as-directory-alist nil
  "Association list of \( TYPE \. FUNC \) pairs.

	       (temp (ange-ftp-make-tmp-name host))
	       ;; What we REALLY need here is a way to determine if the mode
	       ;; of the transfer is irrelevant, i.e. we can use binary mode
	       ;; regardless. Maybe a system-type to host-type lookup?
	       (binary (or (ange-ftp-binary-file filename)
			   (and (not (eq system-type 'windows-nt))
				(eq (ange-ftp-host-type host user) 'unix))))
	       (cmd (if append 'append 'put))
	       (abbr (ange-ftp-abbreviate-filename filename)))
	  (unwind-protect
	      (progn
		(let ((executing-kbd-macro t)
		      (filename (buffer-file-name))
		      (mod-p (buffer-modified-p)))
		  (unwind-protect
		      (ange-ftp-real-write-region start end temp nil visit)
		    ;; cleanup forms
		    (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)))

	      (progn
		(set-visited-file-modtime '(0 0))
		(ange-ftp-set-buffer-mode)
		(setq buffer-file-name filename)
		(set-buffer-modified-p nil)))
	  (ange-ftp-message "Wrote %s" abbr)
	  (ange-ftp-add-file-entry filename))
      (ange-ftp-real-write-region start end filename append visit))))

(defun ange-ftp-insert-file-contents (filename &optional visit beg end replace)

	      (let* ((host (nth 0 parsed))
		     (user (nth 1 parsed))
		     (name (ange-ftp-quote-string (nth 2 parsed)))
		     (temp (ange-ftp-make-tmp-name host))
		     (binary (or (ange-ftp-binary-file filename)
				 (and (not (eq system-type 'windows-nt))
				      (eq (ange-ftp-host-type host user) 'unix))))
		     (abbr (ange-ftp-abbreviate-filename filename))
		     size)
		(unwind-protect
		    (progn
		      (if binary

	     (t-user (and t-parsed (nth 1 t-parsed)))
	     (t-name (and t-parsed (ange-ftp-quote-string (nth 2 t-parsed))))
	     (t-abbr (ange-ftp-abbreviate-filename newname filename))
	     (binary (or (ange-ftp-binary-file filename)
			 (ange-ftp-binary-file newname)
			 (and (not (eq system-type 'windows-nt))
			      (eq (ange-ftp-host-type f-host f-user) 'unix)
			      (eq (ange-ftp-host-type t-host t-user) 'unix))))
	     temp1
	     temp2)

	;; check to see if we can overwrite

		      (concat file "/")
		    file))))
	     completions)))

      (if (or (and (eq system-type 'windows-nt)
		   (string-match "[^a-zA-Z]?[a-zA-Z]:[/\]" ange-ftp-this-dir))
	      (string-equal "/" ange-ftp-this-dir))
	  (nconc (all-completions file (ange-ftp-generate-root-prefixes))
		 (ange-ftp-real-file-name-all-completions file
							  ange-ftp-this-dir))
	(ange-ftp-real-file-name-all-completions file ange-ftp-this-dir)))))

(or (assoc "^/[^/:]*[^/:.]:" file-name-handler-alist)
    (setq file-name-handler-alist
	  (cons '("^/[^/:]*[^/:.]:" . ange-ftp-hook-function)
		file-name-handler-alist)))

;;; Real ange-ftp file names prefixed with a drive letter.
;;;###autoload
(and (memq system-type '(ms-dos windows-nt))
     (or (assoc "^[a-zA-Z]:/[^/:]*[^/:.]:" file-name-handler-alist)
	 (setq file-name-handler-alist
	       (cons '("^[a-zA-Z]:/[^/:]*[^/:.]:" . ange-ftp-hook-function)
		     file-name-handler-alist))))

;;; This regexp recognizes and absolute filenames with only one component,
;;; for the sake of hostname completion.
;;;###autoload
(or (assoc "^/[^/:]*\\'" file-name-handler-alist)
    (setq file-name-handler-alist

  (ange-ftp-run-real-handler 'file-name-nondirectory args))
(defun ange-ftp-real-file-name-as-directory (&rest args)
  (ange-ftp-run-real-handler 'file-name-as-directory args))
(defun ange-ftp-real-directory-file-name (&rest args)
  (ange-ftp-run-real-handler 'directory-file-name args))
(or (and (eq system-type 'windows-nt)
	 ;; Windows handler for [A-Z]: drive name on local disks
	 (defun ange-ftp-real-expand-file-name (&rest args)
	   (ange-ftp-run-real-handler 'ange-ftp-real-expand-file-name-actual args)))
(defun ange-ftp-real-expand-file-name (&rest args)
  (ange-ftp-run-real-handler 'expand-file-name args)))
(defun ange-ftp-real-make-directory (&rest args)
  (ange-ftp-run-real-handler 'make-directory args))
(defun ange-ftp-real-delete-directory (&rest args)
  (ange-ftp-run-real-handler 'delete-directory args))
(defun ange-ftp-real-insert-file-contents (&rest args)

;;(or (assq 'cms ange-ftp-dired-get-filename-alist)
;;    (setq ange-ftp-dired-get-filename-alist
;;	  (cons '(cms . ange-ftp-dired-cms-get-filename)
;;		ange-ftp-dired-get-filename-alist)))

;;
(and (eq system-type 'windows-nt)
     (setq ange-ftp-disable-netrc-security-check t))

;; If a drive letter has been added, remote it.  Otherwise, if the drive
;; letter existed before, leave it.
(defun ange-ftp-real-expand-file-name-actual (&rest args)
  (let (old-name new-name final drive-letter)
    (setq old-name (car args))
    (setq new-name (ange-ftp-run-real-handler 'expand-file-name args))
    (setq drive-letter (substring new-name 0 2))
    ;; I'd like to distill the following lines into one (if) statement
    ;;   removing the need for the temp final variable
    (setq final new-name)
    (if (not (equal (substring old-name 0 1) "~"))
	(if (or (< (length old-name) 2)
		(not (string-match "/[a-zA-Z]:" old-name)))
	    (setq final (substring new-name 2))))
    final))


;;;; ------------------------------------------------------------
;;;; Finally provide package.
;;;; ------------------------------------------------------------

(provide 'ange-ftp)

22278:7a9f75f6e065

(defcustom ange-ftp-netrc-filename "~/.netrc"
  "*File in .netrc format to search for passwords."
  :group 'ange-ftp
  :type 'file)

(defcustom ange-ftp-disable-netrc-security-check (eq system-type 'windows-nt)
  "*If non-nil avoid checking permissions on the .netrc file."
  :group 'ange-ftp
  :type 'boolean)

(defcustom ange-ftp-default-user nil

      (goto-char (point-max))
      (set-marker (process-mark proc) (point)))
    (process-kill-without-query proc)
    (set-process-sentinel proc (function ange-ftp-process-sentinel))
    (set-process-filter proc (function ange-ftp-process-filter))
    ;; On Windows, the standard ftp client buffers its output (because
    ;; stdout is a pipe handle) so the startup message may never appear:
    ;; `accept-process-output' at this point would hang indefinitely.
    ;; However, sending an innocuous command ("help foo") forces some
    ;; output that will be ignored, which is just as good.  Once we
    ;; start sending normal commands, the output no longer appears to be
    ;; buffered, and everything works correctly.  My guess is that the
    ;; output of interest is being sent to stderr which is not buffered.
    (when (eq system-type 'windows-nt)
      ;; force ftp output to be treated as DOS text, otherwise the
      ;; output of "help foo" confuses the EOL detection logic.
      (set-process-coding-system proc 'raw-text-dos)
      (process-send-string proc "help foo\n"))
    (accept-process-output proc)	;wait for ftp startup message
    proc))

(put 'internal-ange-ftp-mode 'mode-class 'special)

(defun internal-ange-ftp-mode ()

	   (not (eq host-type 'unix))
	   (let* ((ange-ftp-good-msgs (concat ange-ftp-expand-dir-regexp
					      "\\|"
					      ange-ftp-good-msgs))
		  (result (ange-ftp-send-cmd host user
					     (list 'get dir grep-null-device)
					     (format "expanding %s" dir)))
		  (line (cdr result)))
	     (setq res
		   (if (string-match ange-ftp-expand-dir-regexp line)
		       (substring line 

	  
	  ;; If name starts with //, preserve that, for apollo system.
	  (if (not (string-match "^//" name))
	      (progn
		(setq name (ange-ftp-real-expand-file-name name))
		;; Strip off drive specifier added on windows-nt
		(if (and (eq system-type 'windows-nt)
			 (string-match "^[a-zA-Z]:" name))
		    (setq name (substring name 2)))
		(if (string-match "^//" name)
		    (setq name (substring name 1)))))
	  
	  ;; Now substitute the expanded name back into the overall filename.
	  (ange-ftp-replace-name-component n name))

	 (ange-ftp-real-file-name-directory n))))))

(defun ange-ftp-expand-file-name (name &optional default)
  "Documented as original."
  (save-match-data
    (setq default (or default default-directory))
    (cond ((eq (string-to-char name) ?~)
	   (ange-ftp-real-expand-file-name name))
	  ((eq (string-to-char name) ?/)
	   (ange-ftp-canonize-filename name))
	  ((and (eq system-type 'windows-nt)
		(or (string-match "^[a-zA-Z]:" name)
		    (string-match "^[a-zA-Z]:" default)))
	   (ange-ftp-real-expand-file-name name default))
	  ((zerop (length name))
	   (ange-ftp-canonize-filename default))
	  ((ange-ftp-canonize-filename
	    (concat (file-name-as-directory default) name))))))

;;; These are problems--they are currently not enabled.

(defvar ange-ftp-file-name-as-directory-alist nil
  "Association list of \( TYPE \. FUNC \) pairs.

	       (temp (ange-ftp-make-tmp-name host))
	       ;; What we REALLY need here is a way to determine if the mode
	       ;; of the transfer is irrelevant, i.e. we can use binary mode
	       ;; regardless. Maybe a system-type to host-type lookup?
	       (binary (or (ange-ftp-binary-file filename)
			   (eq (ange-ftp-host-type host user) 'unix)))
	       (cmd (if append 'append 'put))
	       (abbr (ange-ftp-abbreviate-filename filename))
	       ;; we need to reset `last-coding-system-used' to its
	       ;; value immediately after calling the real write-region,
	       ;; so that `basic-save-buffer' doesn't see whatever value
	       ;; might be used when communicating with the ftp process.
	       (coding-system-used last-coding-system-used))
	  (unwind-protect
	      (progn
		(let ((executing-kbd-macro t)
		      (filename (buffer-file-name))
		      (mod-p (buffer-modified-p)))
		  (unwind-protect
		      (ange-ftp-real-write-region start end temp nil visit)
		    ;; cleanup forms
		    (setq buffer-file-name filename)
		    (set-buffer-modified-p mod-p)))
		;; save value used by the real write-region
		(setq coding-system-used last-coding-system-used)
		(if binary
		    (ange-ftp-set-binary-mode host user))

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

	      (progn
		(set-visited-file-modtime '(0 0))
		(ange-ftp-set-buffer-mode)
		(setq buffer-file-name filename)
		(set-buffer-modified-p nil)))
	  ;; ensure `last-coding-system-used' has an appropriate value
	  (setq last-coding-system-used coding-system-used)
	  (ange-ftp-message "Wrote %s" abbr)
	  (ange-ftp-add-file-entry filename))
      (ange-ftp-real-write-region start end filename append visit))))

(defun ange-ftp-insert-file-contents (filename &optional visit beg end replace)

	      (let* ((host (nth 0 parsed))
		     (user (nth 1 parsed))
		     (name (ange-ftp-quote-string (nth 2 parsed)))
		     (temp (ange-ftp-make-tmp-name host))
		     (binary (or (ange-ftp-binary-file filename)
				 (eq (ange-ftp-host-type host user) 'unix)))
		     (abbr (ange-ftp-abbreviate-filename filename))
		     size)
		(unwind-protect
		    (progn
		      (if binary

	     (t-user (and t-parsed (nth 1 t-parsed)))
	     (t-name (and t-parsed (ange-ftp-quote-string (nth 2 t-parsed))))
	     (t-abbr (ange-ftp-abbreviate-filename newname filename))
	     (binary (or (ange-ftp-binary-file filename)
			 (ange-ftp-binary-file newname)
			 (and (eq (ange-ftp-host-type f-host f-user) 'unix)
			      (eq (ange-ftp-host-type t-host t-user) 'unix))))
	     temp1
	     temp2)

	;; check to see if we can overwrite

		      (concat file "/")
		    file))))
	     completions)))

      (if (or (and (eq system-type 'windows-nt)
		   (string-match "^[a-zA-Z]:[/\]$" ange-ftp-this-dir))
	      (string-equal "/" ange-ftp-this-dir))
	  (nconc (all-completions file (ange-ftp-generate-root-prefixes))
		 (ange-ftp-real-file-name-all-completions file
							  ange-ftp-this-dir))
	(ange-ftp-real-file-name-all-completions file ange-ftp-this-dir)))))

(or (assoc "^/[^/:]*[^/:.]:" file-name-handler-alist)
    (setq file-name-handler-alist
	  (cons '("^/[^/:]*[^/:.]:" . ange-ftp-hook-function)
		file-name-handler-alist)))

;;; This regexp recognizes and absolute filenames with only one component,
;;; for the sake of hostname completion.
;;;###autoload
(or (assoc "^/[^/:]*\\'" file-name-handler-alist)
    (setq file-name-handler-alist

  (ange-ftp-run-real-handler 'file-name-nondirectory args))
(defun ange-ftp-real-file-name-as-directory (&rest args)
  (ange-ftp-run-real-handler 'file-name-as-directory args))
(defun ange-ftp-real-directory-file-name (&rest args)
  (ange-ftp-run-real-handler 'directory-file-name args))
(defun ange-ftp-real-expand-file-name (&rest args)
  (ange-ftp-run-real-handler 'expand-file-name args))
(defun ange-ftp-real-make-directory (&rest args)
  (ange-ftp-run-real-handler 'make-directory args))
(defun ange-ftp-real-delete-directory (&rest args)
  (ange-ftp-run-real-handler 'delete-directory args))
(defun ange-ftp-real-insert-file-contents (&rest args)

;;(or (assq 'cms ange-ftp-dired-get-filename-alist)
;;    (setq ange-ftp-dired-get-filename-alist
;;	  (cons '(cms . ange-ftp-dired-cms-get-filename)
;;		ange-ftp-dired-get-filename-alist)))

;;;; ------------------------------------------------------------
;;;; Finally provide package.
;;;; ------------------------------------------------------------

(provide 'ange-ftp)