X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/8f6769c4f1d0ff057d009ee62bc1ec00a5294fa7..4be9beaf4e4120f67dbf525a84789525bfef2ef8:/lisp/ange-ftp.el diff --git a/lisp/ange-ftp.el b/lisp/ange-ftp.el index ecee7db88d..fe9bc4492f 100644 --- a/lisp/ange-ftp.el +++ b/lisp/ange-ftp.el @@ -701,7 +701,7 @@ These mean that the FTP process should (or already has) been killed." :type 'regexp) (defcustom ange-ftp-tmp-name-template - (concat system-tmp-directory "/ange-ftp") + (expand-file-name "ange-ftp" temporary-file-directory) "*Template used to create temporary files." :group 'ange-ftp :type 'directory) @@ -721,7 +721,7 @@ cross-mounted." :group 'ange-ftp :type 'file) -(defcustom ange-ftp-disable-netrc-security-check nil +(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) @@ -740,8 +740,8 @@ since setting `ange-ftp-default-user' directly does not affect the cached information." :group 'ange-ftp :type '(choice (const :tag "Default" nil) - (const :tag "Prompt" t) - string)) + string + (other :tag "Prompt" t))) (defcustom ange-ftp-netrc-default-user nil "Alternate default user name to use when none is specified. @@ -782,9 +782,9 @@ if there is one." If a string, then use that string as the password. If nil, prompt the user for a password." :group 'ange-ftp - :type '(choice (const :tag "User address" t) - (const :tag "Prompt" nil) - string)) + :type '(choice (const :tag "Prompt" nil) + string + (other :tag "User address" t))) (defcustom ange-ftp-dumb-unix-host-regexp nil "*If non-nil, regexp matching hosts on which `dir' command lists directory." @@ -1972,23 +1972,20 @@ on the gateway machine to do the ftp instead." (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))) + ;; 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) @@ -2247,6 +2244,14 @@ and NOWAIT." (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) + (ange-ftp-cd host user (nth 1 cmd)) + (setq cmd1 ".")) + ;; If the remote ls can take switches, put them in (or (memq host-type ange-ftp-dumb-host-types) (setq cmd0 'ls @@ -2966,7 +2971,7 @@ logged in as user USER and cd'd to directory DIR." "\\|" ange-ftp-good-msgs)) (result (ange-ftp-send-cmd host user - (list 'get dir "/dev/null") + (list 'get dir null-device) (format "expanding %s" dir))) (line (cdr result))) (setq res @@ -3032,7 +3037,10 @@ logged in as user USER and cd'd to directory DIR." (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))))) @@ -3049,22 +3057,19 @@ logged in as user USER and cd'd to directory DIR." (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)))))))) + (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) (string-match "^[a-zA-Z]:" name)) - name) ; when on local drive, return it as-is + ((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 (or default default-directory))) + (ange-ftp-canonize-filename default)) ((ange-ftp-canonize-filename - (concat (file-name-as-directory (or default default-directory)) - name)))))) + (concat (file-name-as-directory default) name)))))) ;;; These are problems--they are currently not enabled. @@ -3139,10 +3144,14 @@ system TYPE.") ;; 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)))) + (eq (ange-ftp-host-type host user) 'unix))) (cmd (if append 'append 'put)) - (abbr (ange-ftp-abbreviate-filename filename))) + (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) @@ -3153,6 +3162,8 @@ system TYPE.") ;; 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)) @@ -3180,6 +3191,8 @@ system TYPE.") (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)))) @@ -3203,8 +3216,7 @@ system TYPE.") (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)))) + (eq (ange-ftp-host-type host user) 'unix))) (abbr (ange-ftp-abbreviate-filename filename)) size) (unwind-protect @@ -3489,8 +3501,7 @@ system TYPE.") (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) + (and (eq (ange-ftp-host-type f-host f-user) 'unix) (eq (ange-ftp-host-type t-host t-user) 'unix)))) temp1 temp2) @@ -3779,7 +3790,7 @@ system TYPE.") completions))) (if (or (and (eq system-type 'windows-nt) - (string-match "[^a-zA-Z]?[a-zA-Z]:[/\]" ange-ftp-this-dir)) + (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 @@ -3811,12 +3822,15 @@ system TYPE.") file tbl ange-ftp-this-dir (function ange-ftp-file-entry-active-p))))))) - (if (string-equal "/" ange-ftp-this-dir) + (if (or (and (eq system-type 'windows-nt) + (string-match "^[a-zA-Z]:[/\\]$" ange-ftp-this-dir)) + (string-equal "/" ange-ftp-this-dir)) (try-completion file (nconc (ange-ftp-generate-root-prefixes) (mapcar 'list - (ange-ftp-real-file-name-all-completions file "/")))) + (ange-ftp-real-file-name-all-completions + file ange-ftp-this-dir)))) (ange-ftp-real-file-name-completion file ange-ftp-this-dir))))) @@ -3839,9 +3853,15 @@ system TYPE.") ;;(define-key minibuffer-local-completion-map "\C-r" 'ange-ftp-re-read-dir) ;;(define-key minibuffer-local-must-match-map "\C-r" 'ange-ftp-re-read-dir) -;; Force a re-read of the directory DIR. If DIR is omitted then it defaults -;; to the directory part of the contents of the current buffer. -(defun ange-ftp-re-read-dir (&optional dir) +;; The autoload cookie is to make sure the doc is always available. +;;;###autoload (defalias 'ange-ftp-re-read-dir 'ange-ftp-reread-dir) +;;;###autoload +(defun ange-ftp-reread-dir (&optional dir) + "Reread remote directory DIR to update the directory cache. +The implementation of remote ftp file names caches directory contents +for speed. Therefore, when new remote files are created, Emacs +may not know they exist. You can use this command to reread a specific +directory, so that Emacs will know its current contents." (interactive) (if dir (setq dir (expand-file-name dir)) @@ -4083,15 +4103,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (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, +;;; This regexp recognizes absolute filenames with only one component, ;;; for the sake of hostname completion. ;;;###autoload (or (assoc "^/[^/:]*\\'" file-name-handler-alist) @@ -4099,8 +4111,10 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (cons '("^/[^/:]*\\'" . ange-ftp-completion-hook-function) file-name-handler-alist))) -;;; Absolute file names prefixed with a drive letter. -;;;###autoload +;;; This regexp recognizes absolute filenames with only one component +;;; on Windows, for the sake of hostname completion. +;;; NB. Do not mark this as autoload, because it is very common to +;;; do completions in the root directory of drives on Windows. (and (memq system-type '(ms-dos windows-nt)) (or (assoc "^[a-zA-Z]:/[^/:]*\\'" file-name-handler-alist) (setq file-name-handler-alist @@ -4185,12 +4199,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (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))) + (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) @@ -5682,27 +5692,6 @@ Other orders of $ and _ seem to all work just fine.") ;; (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.