X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/f469f80c7d95ab4bc4a85279caf8a32fbba38962..8e735883f4696be337577300537480fe64f11fdf:/lisp/ange-ftp.el diff --git a/lisp/ange-ftp.el b/lisp/ange-ftp.el index 099d60660f..2b79cf5757 100644 --- a/lisp/ange-ftp.el +++ b/lisp/ange-ftp.el @@ -1,6 +1,6 @@ ;;; ange-ftp.el --- transparent FTP support for GNU Emacs -;;; Copyright (C) 1989, 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;;; Copyright (C) 1989,90,91,92,93,94,95 Free Software Foundation, Inc. ;;; ;; Author: Andy Norman (ange@hplb.hpl.hp.com) ;; Keywords: comm @@ -63,8 +63,7 @@ ;;; specially. The variable `ange-ftp-generate-anonymous-password' ;;; controls what happens: if the value of this variable is a string, ;;; then this is used as the password; if non-nil (the default), then -;;; a password is created from the name of the user and the hostname -;;; of the machine on which GNU Emacs is running; if nil then the user +;;; the value of `user-mail-address' is used; if nil then the user ;;; is prompted for a password as normal. ;;; "Dumb" UNIX hosts: @@ -214,6 +213,14 @@ ;;; If you have a "smart" ftp program that allows you to issue commands like ;;; "USER foo@bar" which do nice proxy things, then look at the variables ;;; ange-ftp-smart-gateway and ange-ftp-smart-gateway-port. +;;; +;;; Otherwise, if there is an alternate ftp program that implements proxy in +;;; a transparent way (i.e. w/o specifying the proxy host), that will +;;; connect you directly to the desired destination host: +;;; Set ange-ftp-gateway-ftp-program-name to that program's name. +;;; Set ange-ftp-local-host-regexp to a value as stated earlier on. +;;; Leave ange-ftp-gateway-host set to nil. +;;; Set ange-ftp-smart-gateway to t. ;;; Tips for using ange-ftp: ;;; @@ -387,8 +394,8 @@ ;;; 2. Some combinations of FTP clients and servers break and get out of sync ;;; when asked to list a non-existent directory. Some of the ai.mit.edu ;;; machines cause this problem for some FTP clients. Using -;;; ange-ftp-kill-process can be used to restart the ftp process, which -;;; should get things back in synch. +;;; ange-ftp-kill-ftp-process can restart the ftp process, which +;;; should get things back in sync. ;;; ;;; 3. Ange-ftp does not check to make sure that when creating a new file, ;;; you provide a valid filename for the remote operating system. @@ -631,13 +638,11 @@ parenthesized expressions in REGEXP for the components (in that order).") (defvar ange-ftp-multi-msgs "^220-\\|^230-\\|^226\\|^25.-\\|^221-\\|^200-\\|^331-\\|^4[25]1-\\|^530-" - "*Regular expression matching messages from the ftp process that start -a multiline reply.") + "*Regular expression matching the start of a multiline ftp reply.") (defvar ange-ftp-good-msgs "^220 \\|^230 \\|^226 \\|^25. \\|^221 \\|^200 \\|^[Hh]ash mark" - "*Regular expression matching messages from the ftp process that indicate -that the action that was initiated has completed successfully.") + "*Regular expression matching ftp \"success\" messages.") ;; CMS and the odd VMS machine say 200 Port rather than 200 PORT. ;; Also CMS machines use a multiline 550- reply to say that you @@ -648,21 +653,19 @@ that the action that was initiated has completed successfully.") (defvar ange-ftp-skip-msgs (concat "^200 \\(PORT\\|Port\\) \\|^331 \\|^150 \\|^350 \\|^[0-9]+ bytes \\|" "^Connected \\|^$\\|^Remote system\\|^Using\\|^ \\|Password:\\|" + "^Data connection \\|" "^local:\\|^Trying\\|^125 \\|^550-\\|^221 .*oodbye") - "*Regular expression matching messages from the ftp process that can be -ignored.") + "*Regular expression matching ftp messages that can be ignored.") (defvar ange-ftp-fatal-msgs (concat "^ftp: \\|^Not connected\\|^530 \\|^4[25]1 \\|rcmd: \\|" "^No control connection\\|unknown host\\|^lost connection") - "*Regular expression matching messages from the FTP process that indicate -something has gone drastically wrong attempting the action that was -initiated and that the FTP process should (or already has) been killed.") + "*Regular expression matching ftp messages that indicate serious errors. +These mean that the FTP process should (or already has) been killed.") (defvar ange-ftp-gateway-fatal-msgs "No route to host\\|Connection closed\\|No such host\\|Login incorrect" - "*Regular expression matching messages from the rlogin / telnet process that -indicates that logging in to the gateway machine has gone wrong.") + "*Regular expression matching login failure messages from rlogin/telnet.") (defvar ange-ftp-xfer-size-msgs "^150 .* connection for .* (\\([0-9]+\\) bytes)" @@ -696,13 +699,12 @@ If non-nil but not a string, the user is prompted for the name.") "*Account password to use when the user is the same as ange-ftp-default-user.") (defvar ange-ftp-generate-anonymous-password t - "*If t, use a password of user@host when logging in as the anonymous user. -If a string then use that as the password. -If nil then prompt the user for a password.") + "*If t, use value of `user-mail-address' as password for anonymous ftp. +If a string, then use that string as the password. +If nil, prompt the user for a password.") (defvar ange-ftp-dumb-unix-host-regexp nil - "*If non-nil, if the host being ftp'd to matches this regexp then the FTP -process uses the \'dir\' command to get directory information.") + "*If non-nil, regexp matching hosts on which `dir' command lists directory.") (defvar ange-ftp-binary-file-name-regexp (concat "\\.[zZ]$\\|\\.lzh$\\|\\.arc$\\|\\.zip$\\|\\.zoo$\\|\\.tar$\\|" @@ -715,23 +717,22 @@ process uses the \'dir\' command to get directory information.") "*Name of host to use as gateway machine when local FTP isn't possible.") (defvar ange-ftp-local-host-regexp ".*" - "*If a host being FTP'd to matches this regexp then the ftp process is started -locally, otherwise the FTP process is started on \`ange-ftp-gateway-host\' -instead.") + "*Regexp selecting hosts which can be reached directly with ftp. +For other hosts the FTP process is started on \`ange-ftp-gateway-host\' +instead, and/or reached via \`ange-ftp-gateway-ftp-program-name\'.") (defvar ange-ftp-gateway-program-interactive nil - "*If non-nil then the gateway program is expected to connect to the gateway -machine and eventually give a shell prompt. Both telnet and rlogin do something -like this.") - -(defvar ange-ftp-gateway-program (if (eq system-type 'hpux) "remsh" "rsh") - "*Name of program to spawn a shell on the gateway machine. Valid candidates -are rsh (remsh on hp-ux), telnet and rlogin. See also the gateway variable -above.") - -(defvar ange-ftp-gateway-prompt-pattern "^[^#$%>;]*[#$%>;] *" - "*Regexp used to detect that the logging-in sequence is completed on the -gateway machine and that the shell is now awaiting input. Make this regexp as + "*If non-nil then the gateway program should give a shell prompt. +Both telnet and rlogin do something like this.") + +(defvar ange-ftp-gateway-program remote-shell-program + "*Name of program to spawn a shell on the gateway machine. +Valid candidates are rsh (remsh on some systems), telnet and rlogin. See +also the gateway variable above.") + +(defvar ange-ftp-gateway-prompt-pattern "^[^#$%>;\n]*[#$%>;] *" + "*Regexp matching prompt after complete login sequence on gateway machine. +A match for this means the shell is now awaiting input. Make this regexp as strict as possible; it shouldn't match *anything* at all except the user's initial prompt. The above string will fail under most SUN-3's since it matches the login banner.") @@ -740,12 +741,14 @@ matches the login banner.") (if (eq system-type 'hpux) "stty -onlcr -echo\n" "stty -echo nl\n") - "*Command to use after logging in to the gateway machine to stop the terminal -echoing each command and to strip out trailing ^M characters.") + "*Set up terminal after logging in to the gateway machine. +This command should stop the terminal from echoing each command, and +arrange to strip out trailing ^M characters.") (defvar ange-ftp-smart-gateway nil - "*If the gateway FTP is smart enough to use proxy server, then don't bother -telnetting etc, just issue a user@host command instead.") + "*Non-nil means the ftp gateway and/or the gateway ftp program is smart. +Don't bother telnetting, etc., already connected to desired host transparently, +or just issue a user@host command in case \`ange-ftp-gateway-host\' is non-nil.") (defvar ange-ftp-smart-gateway-port "21" "*Port on gateway machine to use when smart gateway is in operation.") @@ -771,7 +774,7 @@ outputs a suitable response to the HASH command.") "*Name of FTP program to run.") (defvar ange-ftp-gateway-ftp-program-name "ftp" - "*Name of FTP program to run on gateway machine. + "*Name of FTP program to run when accessing non-local hosts. Some AT&T folks claim to use something called `pftp' here.") (defvar ange-ftp-ftp-program-args '("-i" "-n" "-g" "-v") @@ -784,8 +787,8 @@ Some AT&T folks claim to use something called `pftp' here.") "*Non-nil means make backup files for \"magic\" remote files.") (defvar ange-ftp-retry-time 5 - "*Number of seconds to wait before retrying if a file or listing -doesn't arrive. This might need to be increased for very slow connections.") + "*Number of seconds to wait before retry if file or listing doesn't arrive. +This might need to be increased for very slow connections.") (defvar ange-ftp-auto-save 0 "If 1, allows ange-ftp files to be auto-saved. @@ -857,8 +860,6 @@ SIZE, if supplied, should be a prime number." ;;;; Internal variables. ;;;; ------------------------------------------------------------ -(defconst ange-ftp-version "$Revision: 1.36 $") - (defvar ange-ftp-data-buffer-name " *ftp data*" "Buffer name to hold directory listing data received from ftp process.") @@ -918,24 +919,6 @@ SIZE, if supplied, should be a prime number." ;; (put 'ftp-error 'error-message "FTP error") ;;; ------------------------------------------------------------ -;;; Match-data support (stolen from Kyle I think) -;;; ------------------------------------------------------------ - -(defmacro ange-ftp-save-match-data (&rest body) - "Execute the BODY forms, restoring the global value of the match data. -Also makes matching case-sensitive within BODY." - (let ((original (make-symbol "match-data")) - case-fold-search) - (list - 'let (list (list original '(match-data))) - (list 'unwind-protect - (cons 'progn body) - (list 'store-match-data original))))) - -(put 'ange-ftp-save-match-data 'lisp-indent-hook 0) -(put 'ange-ftp-save-match-data 'edebug-form-hook '(&rest form)) - -;;; ------------------------------------------------------------ ;;; Enhanced message support. ;;; ------------------------------------------------------------ @@ -944,15 +927,18 @@ Also makes matching case-sensitive within BODY." Args are as in `message': a format string, plus arguments to be formatted." (let ((msg (apply (function format) fmt args)) (max (window-width (minibuffer-window)))) - (if (>= (length msg) max) - (setq msg (concat "> " (substring msg (- 3 max))))) - (message "%s" msg))) + (if noninteractive + msg + (if (>= (length msg) max) + ;; Take just the last MAX - 3 chars of the string. + (setq msg (concat "> " (substring msg (- 3 max))))) + (message "%s" msg)))) (defun ange-ftp-abbreviate-filename (file &optional new) "Abbreviate the file name FILE relative to the default-directory. If the optional parameter NEW is given and the non-directory parts match, only return the directory part of FILE." - (ange-ftp-save-match-data + (save-match-data (if (and default-directory (string-match (concat "^" (regexp-quote default-directory) @@ -1045,7 +1031,7 @@ Optional DEFAULT is password to start with." (if (ange-ftp-lookup-passwd host user) (throw 'found-one host)))) ange-ftp-user-hashtable) - (ange-ftp-save-match-data + (save-match-data (ange-ftp-map-hashtable (function (lambda (key value) @@ -1078,7 +1064,7 @@ Optional DEFAULT is password to start with." ange-ftp-generate-anonymous-password) (if (stringp ange-ftp-generate-anonymous-password) ange-ftp-generate-anonymous-password - (concat (user-login-name) "@" (system-name)))) + user-mail-address)) ;; see if same user has logged in to other hosts; if so then prompt ;; with the password that was used there. @@ -1140,10 +1126,11 @@ Optional DEFAULT is password to start with." (concat (file-name-directory file) temp))))) file) +;; Move along current line looking for the value of the TOKEN. +;; Valid separators between TOKEN and its value are commas and +;; whitespace. Second arg LIMIT is a limit for the search. + (defun ange-ftp-parse-netrc-token (token limit) - "Move along current line looking for the value of the TOKEN. -Valid separators between TOKEN and its value are commas and -whitespace. Second arg LIMIT is a limit for the search." (if (search-forward token limit t) (let (beg) (skip-chars-forward ", \t\r\n" limit) @@ -1157,16 +1144,27 @@ whitespace. Second arg LIMIT is a limit for the search." (skip-chars-forward "^, \t\r\n" limit) (buffer-substring beg (point)))))) +;; Extract the values for the tokens `machine', `login', +;; `password' and `account' in the current buffer. If successful, +;; record the information found. + (defun ange-ftp-parse-netrc-group () - "Extract the values for the tokens \`machine\', \`login\', \`password\' -and \`account\' in the current buffer. If successful, record the information -found." - (beginning-of-line) (let ((start (point)) - (end (progn (re-search-forward "machine\\|default" - (point-max) 'end 2) (point))) + (end (save-excursion + (if (looking-at "machine\\>") + ;; Skip `machine' and the machine name that follows. + (progn + (skip-chars-forward "^ \t\n") + (skip-chars-forward " \t\n") + (skip-chars-forward "^ \t\n")) + ;; Skip `default'. + (skip-chars-forward "^ \t\n")) + ;; Find start of the next `machine' or `default' + ;; or the end of the buffer. + (if (re-search-forward "machine\\>\\|default\\>" nil t) + (match-beginning 0) + (point-max)))) machine login password account) - (goto-char start) (setq machine (ange-ftp-parse-netrc-token "machine" end) login (ange-ftp-parse-netrc-token "login" end) password (ange-ftp-parse-netrc-token "password" end) @@ -1193,20 +1191,22 @@ found." (setq ange-ftp-default-account account))))) (goto-char end))) -(defun ange-ftp-parse-netrc () - "Read in ~/.netrc, if one exists. -If ~/.netrc file exists and has the correct permissions then extract the -\`machine\', \`login\', \`password\' and \`account\' information from within." +;; Read in ~/.netrc, if one exists. If ~/.netrc file exists and has +;; the correct permissions then extract the \`machine\', \`login\', +;; \`password\' and \`account\' information from within. +(defun ange-ftp-parse-netrc () ;; We set this before actually doing it to avoid the possibility ;; of an infinite loop if ange-ftp-netrc-filename is an FTP file. (interactive) - (let* ((file (ange-ftp-chase-symlinks - (ange-ftp-real-expand-file-name ange-ftp-netrc-filename))) - (attr (ange-ftp-real-file-attributes file))) + (let (file attr) + (let ((default-directory "/")) + (setq file (ange-ftp-chase-symlinks + (ange-ftp-real-expand-file-name ange-ftp-netrc-filename))) + (setq attr (ange-ftp-real-file-attributes file))) (if (and attr ; file exists. (not (equal (nth 5 attr) ange-ftp-netrc-modtime))) ; file changed - (ange-ftp-save-match-data + (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)))) @@ -1223,6 +1223,7 @@ If ~/.netrc file exists and has the correct permissions then extract the (mapcar 'funcall find-file-hooks) (setq buffer-file-name nil) (goto-char (point-min)) + (skip-chars-forward " \t\n") (while (not (eobp)) (ange-ftp-parse-netrc-group)) (kill-buffer (current-buffer))) @@ -1231,11 +1232,12 @@ If ~/.netrc file exists and has the correct permissions then extract the (sit-for 1)) (setq ange-ftp-netrc-modtime (nth 5 attr)))))) +;; Return a list of prefixes of the form 'user@host:' to be used when +;; completion is done in the root directory. + (defun ange-ftp-generate-root-prefixes () - "Return a list of prefixes of the form 'user@host:' to be used when -completion is done in the root directory." (ange-ftp-parse-netrc) - (ange-ftp-save-match-data + (save-match-data (let (res) (ange-ftp-map-hashtable (function @@ -1266,15 +1268,15 @@ completion is done in the root directory." (defvar ange-ftp-ftp-name-arg "") (defvar ange-ftp-ftp-name-res nil) +;; Parse NAME according to `ange-ftp-name-format' (which see). +;; Returns a list (HOST USER NAME), or nil if NAME does not match the format. (defun ange-ftp-ftp-name (name) - "Parse NAME according to `ange-ftp-name-format' (which see). -Returns a list (HOST USER NAME), or nil if NAME does not match the format." (if (string-equal name ange-ftp-ftp-name-arg) ange-ftp-ftp-name-res (setq ange-ftp-ftp-name-arg name ange-ftp-ftp-name-res - (ange-ftp-save-match-data - (if (string-match (car ange-ftp-name-format) name) + (save-match-data + (if (posix-string-match (car ange-ftp-name-format) name) (let* ((ns (cdr ange-ftp-name-format)) (host (ange-ftp-ftp-name-component 0 ns name)) (user (ange-ftp-ftp-name-component 1 ns name)) @@ -1284,11 +1286,11 @@ Returns a list (HOST USER NAME), or nil if NAME does not match the format." (list host user name)) nil))))) +;; Take a FULLNAME that matches according to ange-ftp-name-format and +;; replace the name component with NAME. (defun ange-ftp-replace-name-component (fullname name) - "Take a FULLNAME that matches according to ange-ftp-name-format and -replace the name component with NAME." - (ange-ftp-save-match-data - (if (string-match (car ange-ftp-name-format) fullname) + (save-match-data + (if (posix-string-match (car ange-ftp-name-format) fullname) (let* ((ns (cdr ange-ftp-name-format)) (elt (nth 2 ns))) (concat (substring fullname 0 (match-beginning elt)) @@ -1306,14 +1308,14 @@ replace the name component with NAME." "Clear any existing minibuffer message; let the minibuffer contents show." (message nil)) +;; Return the name of the buffer that collects output from the ftp process +;; connected to the given HOST and USER pair. (defun ange-ftp-ftp-process-buffer (host user) - "Return the name of the buffer that collects output from the ftp process -connected to the given HOST and USER pair." (concat "*ftp " user "@" host "*")) +;; Display the last chunk of output from the ftp process for the given HOST +;; USER pair, and signal an error including MSG in the text. (defun ange-ftp-error (host user msg) - "Display the last chunk of output from the ftp process for the given HOST -USER pair, and signal an error including MSG in the text." (let ((cur (selected-window)) (pop-up-windows t)) (pop-to-buffer @@ -1327,10 +1329,7 @@ USER pair, and signal an error including MSG in the text." "Set correct modes for the current buffer if visiting a remote file." (if (and (stringp buffer-file-name) (ange-ftp-ftp-name buffer-file-name)) - (progn - (make-local-variable 'make-backup-files) - (setq make-backup-files ange-ftp-make-backup-files) - (auto-save-mode ange-ftp-auto-save)))) + (auto-save-mode ange-ftp-auto-save))) (defun ange-ftp-kill-ftp-process (buffer) "Kill the FTP process associated with BUFFER. @@ -1374,8 +1373,9 @@ then kill the related ftp process." ;;;; ------------------------------------------------------------ (defun ange-ftp-process-handle-line (line proc) - "Look at the given LINE from the ftp process PROC. Try to categorize it -into one of four categories: good, skip, fatal, or unknown." + "Look at the given LINE from the ftp process PROC. +Try to categorize it into one of four categories: +good, skip, fatal, or unknown." (cond ((string-match ange-ftp-xfer-size-msgs line) (setq ange-ftp-xfer-size (ash (string-to-int (substring line @@ -1388,34 +1388,23 @@ into one of four categories: good, skip, fatal, or unknown." (setq ange-ftp-process-busy nil ange-ftp-process-result t ange-ftp-process-result-line line)) + ;; Check this before checking for errors. + ;; Otherwise the last line of these three seems to be an error: + ;; 230-see a significant impact from the move. For those of you who can't + ;; 230-use DNS to resolve hostnames and get an error message like + ;; 230-"ftp.stsci.edu: unknown host", the new IP address will be... + ((string-match ange-ftp-multi-msgs line) + (setq ange-ftp-process-multi-skip t)) ((string-match ange-ftp-fatal-msgs line) (delete-process proc) (setq ange-ftp-process-busy nil ange-ftp-process-result-line line)) - ((string-match ange-ftp-multi-msgs line) - (setq ange-ftp-process-multi-skip t)) (ange-ftp-process-multi-skip t) (t (setq ange-ftp-process-busy nil ange-ftp-process-result-line line)))) -(defun ange-ftp-process-log-string (proc str) - "For a given PROCESS, log the given STRING at the end of its -associated buffer." - (let ((old-buffer (current-buffer))) - (unwind-protect - (let (moving) - (set-buffer (process-buffer proc)) - (setq moving (= (point) (process-mark proc))) - (save-excursion - ;; Insert the text, moving the process-marker. - (goto-char (process-mark proc)) - (insert str) - (set-marker (process-mark proc) (point))) - (if moving (goto-char (process-mark proc)))) - (set-buffer old-buffer)))) - (defun ange-ftp-set-xfer-size (host user bytes) "Set the size of the next FTP transfer in bytes." (let ((proc (ange-ftp-get-process host user))) @@ -1433,7 +1422,8 @@ associated buffer." ange-ftp-hash-mark-count (+ (- (match-end 0) (match-beginning 0)) ange-ftp-hash-mark-count)) - (and ange-ftp-process-msg + (and ange-ftp-hash-mark-unit + ange-ftp-process-msg ange-ftp-process-verbose (not (eq (selected-window) (minibuffer-window))) (not (boundp 'search-message)) ;screws up isearch otherwise @@ -1451,35 +1441,39 @@ associated buffer." (ange-ftp-message "%s...%d%%" ange-ftp-process-msg percent))))))) str) +;; Call the function specified by CONT. CONT can be either a function +;; or a list of a function and some args. The first two parameters +;; passed to the function will be RESULT and LINE. The remaining args +;; will be taken from CONT if a list was passed. + (defun ange-ftp-call-cont (cont result line) - "Call the function specified by CONT. CONT can be either a function or a -list of a function and some args. The first two parameters passed to the -function will be RESULT and LINE. The remaining args will be taken from CONT -if a list was passed." (if cont (if (and (listp cont) (not (eq (car cont) 'lambda))) (apply (car cont) result line (cdr cont)) (funcall cont result line)))) +;; Build up a complete line of output from the ftp PROCESS and pass it +;; on to ange-ftp-process-handle-line to deal with. + (defun ange-ftp-process-filter (proc str) - "Build up a complete line of output from the ftp PROCESS and pass it -on to ange-ftp-process-handle-line to deal with." (let ((buffer (process-buffer proc)) (old-buffer (current-buffer))) ;; see if the buffer is still around... it could have been deleted. (if (buffer-name buffer) (unwind-protect - (ange-ftp-save-match-data + (progn (set-buffer (process-buffer proc)) ;; handle hash mark printing - (and ange-ftp-hash-mark-unit - ange-ftp-process-busy + (and ange-ftp-process-busy (string-match "^#+$" str) (setq str (ange-ftp-process-handle-hash str))) - (ange-ftp-process-log-string proc str) + (comint-output-filter proc str) + ;; Replace STR by the result of the comint processing. + (setq str (buffer-substring comint-last-output-start + (process-mark proc))) (if ange-ftp-process-busy (progn (setq ange-ftp-process-string (concat ange-ftp-process-string @@ -1528,13 +1522,12 @@ on to ange-ftp-process-handle-line to deal with." (defun ange-ftp-process-sentinel (proc str) "When ftp process changes state, nuke all file-entries in cache." - (ange-ftp-save-match-data - (let ((name (process-name proc))) - (if (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)*" name) - (let ((user (substring name (match-beginning 1) (match-end 1))) - (host (substring name (match-beginning 2) (match-end 2)))) - (ange-ftp-wipe-file-entries host user)))) - (setq ange-ftp-ls-cache-file nil))) + (let ((name (process-name proc))) + (if (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)\\*" name) + (let ((user (substring name (match-beginning 1) (match-end 1))) + (host (substring name (match-beginning 2) (match-end 2)))) + (ange-ftp-wipe-file-entries host user)))) + (setq ange-ftp-ls-cache-file nil)) ;;;; ------------------------------------------------------------ ;;;; Gateway support. @@ -1545,13 +1538,13 @@ on to ange-ftp-process-handle-line to deal with." ;; yes, I know that I could simplify the following expression, but it is ;; clearer (to me at least) this way. (and (not ange-ftp-smart-gateway) - (ange-ftp-save-match-data + (save-match-data (not (string-match ange-ftp-local-host-regexp host))))) (defun ange-ftp-use-smart-gateway-p (host) "Returns whether to access this host via a smart gateway." (and ange-ftp-smart-gateway - (ange-ftp-save-match-data + (save-match-data (not (string-match ange-ftp-local-host-regexp host))))) @@ -1608,39 +1601,49 @@ on to ange-ftp-process-handle-line to deal with." (setq ange-ftp-gwp-running nil)) (defun ange-ftp-gwp-filter (proc str) - (ange-ftp-save-match-data - (ange-ftp-process-log-string proc str) - (cond ((string-match "login: *$" str) - (send-string proc - (concat - (let ((ange-ftp-default-user t)) - (ange-ftp-get-user ange-ftp-gateway-host)) - "\n"))) - ((string-match "Password: *$" str) - (send-string proc - (concat - (ange-ftp-get-passwd ange-ftp-gateway-host - (ange-ftp-get-user - ange-ftp-gateway-host)) - "\n"))) - ((string-match ange-ftp-gateway-fatal-msgs str) - (delete-process proc) - (setq ange-ftp-gwp-running nil)) - ((string-match ange-ftp-gateway-prompt-pattern str) - (setq ange-ftp-gwp-running nil - ange-ftp-gwp-status t))))) + (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) + (send-string proc + (concat + (let ((ange-ftp-default-user t)) + (ange-ftp-get-user ange-ftp-gateway-host)) + "\n"))) + ((string-match "Password: *$" str) + (send-string proc + (concat + (ange-ftp-get-passwd ange-ftp-gateway-host + (ange-ftp-get-user + ange-ftp-gateway-host)) + "\n"))) + ((string-match ange-ftp-gateway-fatal-msgs str) + (delete-process proc) + (setq ange-ftp-gwp-running nil)) + ((string-match ange-ftp-gateway-prompt-pattern str) + (setq ange-ftp-gwp-running nil + ange-ftp-gwp-status t)))) (defun ange-ftp-gwp-start (host user name args) "Login to the gateway machine and fire up an ftp process." (let* ((gw-user (ange-ftp-get-user ange-ftp-gateway-host)) - (proc (start-process name name - ange-ftp-gateway-program - ange-ftp-gateway-host)) + ;; It would be nice to make process-connection-type nil, + ;; but that doesn't work: ftp never responds. + ;; Can anyone find a fix for that? + (proc (let ((process-connection-type t)) + (start-process name name + ange-ftp-gateway-program + ange-ftp-gateway-host))) (ftp (mapconcat (function identity) args " "))) (process-kill-without-query proc) (set-process-sentinel proc (function ange-ftp-gwp-sentinel)) (set-process-filter proc (function ange-ftp-gwp-filter)) - (set-marker (process-mark proc) (point)) + (save-excursion + (set-buffer (process-buffer proc)) + (internal-ange-ftp-mode) + (set-marker (process-mark proc) (point))) (setq ange-ftp-gwp-running t ange-ftp-gwp-status nil) (ange-ftp-message "Connecting to gateway %s..." ange-ftp-gateway-host) @@ -1702,7 +1705,7 @@ been queued with no result. CONT will still be called, however." (goto-char (point-max)) (move-marker comint-last-input-start (point)) ;; don't insert the password into the buffer on the USER command. - (ange-ftp-save-match-data + (save-match-data (if (string-match "^user \"[^\"]*\"" cmd) (insert (substring cmd 0 (match-end 0)) " Turtle Power!\n") (insert cmd))) @@ -1726,8 +1729,16 @@ been queued with no result. CONT will still be called, however." "Attempt to resolve the given HOSTNAME using nslookup if possible." (interactive "sHost: ") (if ange-ftp-nslookup-program - (let ((proc (start-process " *nslookup*" " *nslookup*" - ange-ftp-nslookup-program host)) + (let ((default-directory + (if (file-accessible-directory-p default-directory) + default-directory + exec-directory)) + ;; It would be nice to make process-connection-type nil, + ;; but that doesn't work: ftp never responds. + ;; Can anyone find a fix for that? + (proc (let ((process-connection-type t)) + (start-process " *nslookup*" " *nslookup*" + ange-ftp-nslookup-program host))) (res host)) (process-kill-without-query proc) (save-excursion @@ -1747,19 +1758,38 @@ been queued with no result. CONT will still be called, however." If HOST is only ftp-able through a gateway machine then spawn a shell on the gateway machine to do the ftp instead." (let* ((use-gateway (ange-ftp-use-gateway-p host)) - (ftp-prog (if use-gateway + (use-smart-ftp (and (not ange-ftp-gateway-host) + (ange-ftp-use-smart-gateway-p host))) + (ftp-prog (if (or use-gateway + use-smart-ftp) ange-ftp-gateway-ftp-program-name ange-ftp-ftp-program-name)) (args (append (list ftp-prog) ange-ftp-ftp-program-args)) + ;; Without the following binding, ange-ftp-start-process + ;; recurses on file-accessible-directory-p, since it needs to + ;; restart its process in order to determine anything about + ;; default-directory. + (file-name-handler-alist) + (default-directory + (if (file-accessible-directory-p default-directory) + default-directory + exec-directory)) proc) - (if use-gateway - (if ange-ftp-gateway-program-interactive - (setq proc (ange-ftp-gwp-start host user name args)) - (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))) + ;; It would be nice to make process-connection-type nil, + ;; but that doesn't work: ftp never responds. + ;; Can anyone find a fix for that? + (let ((process-connection-type t) + (process-environment process-environment)) + ;; 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 (ange-ftp-gwp-start host user name args)) + (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)))) (process-kill-without-query proc) (save-excursion (set-buffer (process-buffer proc)) @@ -1770,6 +1800,9 @@ on the gateway machine to do the ftp instead." proc)) (defun internal-ange-ftp-mode () + "Major mode for interacting with the FTP process. + +\\{comint-mode-map}" (interactive) (comint-mode) (setq major-mode 'internal-ange-ftp-mode) @@ -1793,7 +1826,15 @@ on the gateway machine to do the ftp instead." (make-local-variable 'ange-ftp-last-percent) (setq ange-ftp-hash-mark-count 0) (setq ange-ftp-xfer-size 0) - (setq ange-ftp-process-result-line ""))) + (setq ange-ftp-process-result-line "") + + (setq comint-prompt-regexp "^ftp> ") + (make-local-variable 'comint-password-prompt-regexp) + ;; This is a regexp that can't match anything. + ;; ange-ftp has its own ways of handling passwords. + (setq comint-password-prompt-regexp "^a\\'z") + (make-local-variable 'paragraph-start) + (setq paragraph-start comint-prompt-regexp))) (defun ange-ftp-smart-login (host user pass account proc) "Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT. @@ -1830,9 +1871,10 @@ host specified in ``ange-ftp-gateway-host''." (defun ange-ftp-normal-login (host user pass account proc) "Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT. PROC is the process to the FTP-client." - (let ((result (ange-ftp-raw-send-cmd + (let* ((nshost (ange-ftp-nslookup-host host)) + (result (ange-ftp-raw-send-cmd proc - (format "open %s" (ange-ftp-nslookup-host host)) + (format "open %s" nshost) (format "Opening FTP connection to %s" host)))) (or (car result) (ange-ftp-error host user @@ -1840,7 +1882,9 @@ PROC is the process to the FTP-client." (cdr result)))) (setq result (ange-ftp-raw-send-cmd proc - (format "user \"%s\" %s %s" user pass account) + (if (ange-ftp-use-smart-gateway-p host) + (format "user \"%s\"@%s %s %s" user nshost pass account) + (format "user \"%s\" %s %s" user pass account)) (format "Logging in as user %s@%s" user host))) (or (car result) (progn @@ -1850,6 +1894,7 @@ PROC is the process to the FTP-client." (concat "USER request failed: " (cdr result))))))) +;; ange@hplb.hpl.hp.com says this should not be changed. (defvar ange-ftp-hash-mark-msgs "[hH]ash mark [^0-9]*\\([0-9]+\\)" "*Regexp matching the FTP client's output upon doing a HASH command.") @@ -1861,7 +1906,7 @@ PROC is the process to the FTP-client." (let* ((status (ange-ftp-raw-send-cmd proc "hash")) (result (car status)) (line (cdr status))) - (ange-ftp-save-match-data + (save-match-data (if (string-match ange-ftp-hash-mark-msgs line) (let ((size (string-to-int (substring line @@ -1875,8 +1920,8 @@ PROC is the process to the FTP-client." (setq ange-ftp-binary-hash-mark-size size))))))))) (defun ange-ftp-get-process (host user) - "Return the process object for a FTP process connected to HOST and -logged in as USER. Create a new process if needed." + "Return an FTP subprocess connected to HOST and logged in as USER. +Create a new process if needed." (let* ((name (ange-ftp-ftp-process-buffer host user)) (proc (get-process name))) (if (and proc (memq (process-status proc) '(run open))) @@ -1889,7 +1934,8 @@ logged in as USER. Create a new process if needed." (setq proc (ange-ftp-start-process host user name)) ;; login to FTP server. - (if (ange-ftp-use-smart-gateway-p host) + (if (and (ange-ftp-use-smart-gateway-p host) + ange-ftp-gateway-host) (ange-ftp-smart-login host user pass account proc) (ange-ftp-normal-login host user pass account proc)) @@ -1952,12 +1998,14 @@ host-type by logging in as USER." ;; (for efficiency) if you log into a particular non-UNIX host frequently. (defvar ange-ftp-fix-name-func-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine + "Alist saying how to convert file name to the host's syntax. +Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine which can change a UNIX file name into a name more suitable for a host of type TYPE.") (defvar ange-ftp-fix-dir-name-func-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine + "Alist saying how to convert directory name to the host's syntax. +Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine which can change UNIX directory name into a directory name more suitable for a host of type TYPE.") @@ -2083,13 +2131,13 @@ and NOWAIT." "^[A-Z0-9._][A-Z0-9._][A-Z0-9._][A-Z0-9._]:$") (defun ange-ftp-guess-host-type (host user) - "Guess at the the host type of HOST by doing a pwd, and examining -the directory syntax." + "Guess at the the host type of HOST. +Works by doing a pwd and examining the directory syntax." (let ((host-type (ange-ftp-host-type host)) (key (concat host "/" user "/~"))) (if (eq host-type 'unix) ;; Note that ange-ftp-host-type returns unix as the default value. - (ange-ftp-save-match-data + (save-match-data (let* ((result (ange-ftp-get-pwd host user)) (dir (car result)) fix-name-func) @@ -2161,11 +2209,11 @@ the directory syntax." ;;;; Remote file and directory listing support. ;;;; ------------------------------------------------------------ +;; Returns whether HOST's FTP server doesn't like \'ls\' or \'dir\' commands +;; to take switch arguments. (defun ange-ftp-dumb-unix-host (host) - "Returns whether HOST's FTP server doesn't like \'ls\' or \'dir\' commands -to take switch arguments." - (and ange-ftp-dumb-unix-host-regexp - (ange-ftp-save-match-data + (and host ange-ftp-dumb-unix-host-regexp + (save-match-data (string-match ange-ftp-dumb-unix-host-regexp host)))) (defun ange-ftp-add-dumb-unix-host (host) @@ -2182,7 +2230,8 @@ to take switch arguments." ange-ftp-host-cache nil))) (defvar ange-ftp-parse-list-func-alist nil - "Association list of \( TYPE \. FUNC \) pairs. The FUNC is a routine + "Alist saying how to parse directory listings for certain OS types. +Association list of \( TYPE \. FUNC \) pairs. The FUNC is a routine which can parse the output from a DIR listing for a host of type TYPE.") ;; With no-error nil, this function returns: @@ -2193,7 +2242,7 @@ which can parse the output from a DIR listing for a host of type TYPE.") ;; ;; With no-error t, it returns: ;; an error if not an ange-ftp-name -;; error if listing is unreable (most likely caused by a slow connection) +;; error if listing is unreadable (most likely caused by a slow connection) ;; nil if ftp error (this is because although asking to list a nonexistent ;; directory on a remote unix machine usually (except ;; maybe for dumb hosts) returns an ls error, but no @@ -2296,15 +2345,16 @@ away in the internal cache." "\\|Nov\\|Dec\\) +[0-3]?[0-9] ")) (defvar ange-ftp-add-file-entry-alist nil - "Association list of pairs \( TYPE \. FUNC \), where FUNC + "Alist saying how to add file entries on certain OS types. +Association list of pairs \( TYPE \. FUNC \), where FUNC is a function to be used to add a file entry for the OS TYPE. The main reason for this alist is to deal with file versions in VMS.") (defvar ange-ftp-delete-file-entry-alist nil - "Association list of pairs \( TYPE \. FUNC \), where FUNC + "Alist saying how to delete files on certain OS types. +Association list of pairs \( TYPE \. FUNC \), where FUNC is a function to be used to delete a file entry for the OS TYPE. -The main reason for this alist is to deal with file versions in -VMS.") +The main reason for this alist is to deal with file versions in VMS.") (defun ange-ftp-add-file-entry (name &optional dir-p) "Add a file entry for file NAME, if its directory info exists." @@ -2395,9 +2445,9 @@ VMS.") ;;; The dl stuff for descriptive listings (defvar ange-ftp-dl-dir-regexp nil - "Regexp matching directories which are listed in dl format. This regexp -shouldn't be anchored with a trailing $ so that it will match subdirectories -as well.") + "Regexp matching directories which are listed in dl format. +This regexp should not be anchored with a trailing `$', because it should +match subdirectories as well.") (defun ange-ftp-add-dl-dir (dir) "Interactively adds a DIR to ange-ftp-dl-dir-regexp." @@ -2430,11 +2480,12 @@ as well.") (ange-ftp-put-hash-entry ".." t tbl) tbl))) +;; Parse the current buffer which is assumed to be in a dired-like listing +;; format, and return a hashtable as the result. If the listing is not really +;; a listing, then return nil. + (defun ange-ftp-parse-dired-listing (&optional switches) - "Parse the current buffer which is assumed to be in a dired-like listing -format, and return a hashtable as the result. If the listing is not really -a listing, then return nil." - (ange-ftp-save-match-data + (save-match-data (cond ((looking-at "^total [0-9]+$") (forward-line 1) @@ -2474,7 +2525,7 @@ This will give an error or return nil, depending on the value of NO-ERROR, if a listing for DIRECTORY cannot be obtained." (setq directory (file-name-as-directory directory)) ;normalize (or (ange-ftp-get-hash-entry directory ange-ftp-files-hashtable) - (ange-ftp-save-match-data + (save-match-data (and (ange-ftp-ls directory ;; This is an efficiency hack. We try to ;; anticipate what sort of listing dired @@ -2507,22 +2558,23 @@ NO-ERROR, if a listing for DIRECTORY cannot be obtained." (ange-ftp-get-hash-entry directory ange-ftp-files-hashtable))))) +;; Given NAME, return the file part that can be used for looking up the +;; file's entry in a hashtable. (defmacro ange-ftp-get-file-part (name) - "Given NAME, return the file part that can be used for looking up the -file's entry in a hashtable." (` (let ((file (file-name-nondirectory (, name)))) (if (string-equal file "") "." file)))) +;; Return whether ange-ftp-file-entry-p and ange-ftp-get-file-entry are +;; allowed to determine if NAME is a sub-directory by listing it directly, +;; rather than listing its parent directory. This is used for efficiency so +;; that a wasted listing is not done: +;; 1. When looking for a .dired file in dired-x.el. +;; 2. The syntax of FILE and DIR make it impossible that FILE could be a valid +;; subdirectory. This is of course an OS dependent judgement. + (defmacro ange-ftp-allow-child-lookup (dir file) - "Return whether ange-ftp-file-entry-p and ange-ftp-get-file-entry are -allowed to determine if NAME is a sub-directory by listing it directly, -rather than listing its parent directory. This is used for efficiency so -that a wasted listing is not done: -1. When looking for a .dired file in dired-x.el. -2. The syntax of FILE and DIR make it impossible that FILE could be a valid - subdirectory. This is of course an OS dependent judgement." (` (not (let* ((efile (, file)) ; expand once. (edir (, dir)) @@ -2612,8 +2664,7 @@ this also returns nil." files)))) (defun ange-ftp-wipe-file-entries (host user) - "Replace the file entry information hashtable with one that doesn't have any -entries for the given HOST, USER pair." + "Get rid of entry for HOST, USER pair from file entry information hashtable." (let ((new-tbl (ange-ftp-make-hashtable (length ange-ftp-files-hashtable)))) (ange-ftp-map-hashtable (function @@ -2638,7 +2689,9 @@ entries for the given HOST, USER pair." (ange-ftp-error host user (concat "BINARY failed: " (cdr result))) (save-excursion (set-buffer (process-buffer (ange-ftp-get-process host user))) - (setq ange-ftp-hash-mark-unit (ash ange-ftp-binary-hash-mark-size -4)))))) + (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." @@ -2647,7 +2700,9 @@ entries for the given HOST, USER pair." (ange-ftp-error host user (concat "ASCII failed: " (cdr result))) (save-excursion (set-buffer (process-buffer (ange-ftp-get-process host user))) - (setq ange-ftp-hash-mark-unit (ash ange-ftp-ascii-hash-mark-size -4)))))) + (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) (let ((result (ange-ftp-send-cmd host user (list 'cd dir) "Doing CD"))) @@ -2662,7 +2717,7 @@ and LINE is the relevant success or fail line from the FTP-client." (line (cdr result)) dir) (if (car result) - (ange-ftp-save-match-data + (save-match-data (and (or (string-match "\"\\([^\"]*\\)\"" line) (string-match " \\([^ ]+\\) " line)) ; stone-age VMS servers! (setq dir (substring line @@ -2675,7 +2730,8 @@ and LINE is the relevant success or fail line from the FTP-client." ;;; ------------------------------------------------------------ (defun ange-ftp-expand-dir (host user dir) - "Return the result of doing a PWD in the current FTP session to machine HOST + "Return the result of doing a PWD in the current FTP session. +Use the connection to machine HOST logged in as user USER and cd'd to directory DIR." (let* ((host-type (ange-ftp-host-type host user)) ;; It is more efficient to call ange-ftp-host-type @@ -2722,7 +2778,7 @@ logged in as user USER and cd'd to directory DIR." (defun ange-ftp-canonize-filename (n) "Take a string and short-circuit //, /. and /.." - (if (string-match ".+//" n) ;don't upset Apollo users + (if (string-match "[^:]+//" n) ;don't upset Apollo users (setq n (substring n (1- (match-end 0))))) (let ((parsed (ange-ftp-ftp-name n))) (if parsed @@ -2757,12 +2813,13 @@ logged in as user USER and cd'd to directory DIR." name)) (error "Unable to obtain CWD"))))) - (setq name (ange-ftp-real-expand-file-name name)) - - ;; see if hit real expand-file-name bug... this will probably annoy - ;; some Apollo people. I'll wait until they shout, however. - (if (string-match "^//" name) - (setq name (substring name 1))) + ;; 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)) @@ -2776,9 +2833,9 @@ logged in as user USER and cd'd to directory DIR." (defun ange-ftp-expand-file-name (name &optional default) "Documented as original." - (ange-ftp-save-match-data + (save-match-data (if (eq (string-to-char name) ?/) - (while (cond ((string-match ".+//" name) ;don't upset Apollo users + (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)))))))) @@ -2795,7 +2852,7 @@ logged in as user USER and cd'd to directory DIR." ;;; These are problems--they are currently not enabled. (defvar ange-ftp-file-name-as-directory-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where + "Association list of \( TYPE \. FUNC \) pairs. FUNC converts a filename to a directory name for the operating system TYPE.") @@ -2817,7 +2874,7 @@ system TYPE.") (let ((parsed (ange-ftp-ftp-name name))) (if parsed (let ((filename (nth 2 parsed))) - (if (ange-ftp-save-match-data + (if (save-match-data (string-match "^~[^/]*$" filename)) name (ange-ftp-replace-name-component @@ -2830,7 +2887,7 @@ system TYPE.") (let ((parsed (ange-ftp-ftp-name name))) (if parsed (let ((filename (nth 2 parsed))) - (if (ange-ftp-save-match-data + (if (save-match-data (string-match "^~[^/]*$" filename)) "" (ange-ftp-real-file-name-nondirectory name))) @@ -2850,7 +2907,7 @@ system TYPE.") ;; Returns non-nil if should transfer FILE in binary mode. (defun ange-ftp-binary-file (file) - (ange-ftp-save-match-data + (save-match-data (string-match ange-ftp-binary-file-name-regexp file))) (defun ange-ftp-write-region (start end filename &optional append visit) @@ -2861,7 +2918,8 @@ system TYPE.") (user (nth 1 parsed)) (name (ange-ftp-quote-string (nth 2 parsed))) (temp (ange-ftp-make-tmp-name host)) - (binary (ange-ftp-binary-file filename)) + (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))) (unwind-protect @@ -2897,6 +2955,7 @@ system TYPE.") (ange-ftp-set-ascii-mode host user))) (if (eq visit t) (progn + (set-visited-file-modtime '(0 0)) (ange-ftp-set-buffer-mode) (setq buffer-file-name filename) (set-buffer-modified-p nil))) @@ -2904,7 +2963,7 @@ system TYPE.") (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) +(defun ange-ftp-insert-file-contents (filename &optional visit beg end replace) (barf-if-buffer-read-only) (setq filename (expand-file-name filename)) (let ((parsed (ange-ftp-ftp-name filename))) @@ -2922,7 +2981,8 @@ system TYPE.") (user (nth 1 parsed)) (name (ange-ftp-quote-string (nth 2 parsed))) (temp (ange-ftp-make-tmp-name host)) - (binary (ange-ftp-binary-file filename)) + (binary (or (ange-ftp-binary-file filename) + (eq (ange-ftp-host-type host user) 'unix))) (abbr (ange-ftp-abbreviate-filename filename)) size) (unwind-protect @@ -2944,9 +3004,8 @@ system TYPE.") (ange-ftp-real-file-readable-p temp)) (setq size - (nth 1 (ange-ftp-real-insert-file-contents temp - visit - beg end))) + (nth 1 (ange-ftp-real-insert-file-contents + temp visit beg end replace))) (signal 'ftp-error (list "Opening input file:" @@ -2957,13 +3016,15 @@ system TYPE.") (ange-ftp-set-ascii-mode host user)) (ange-ftp-del-tmp-name temp)) (if visit - (setq buffer-file-name filename)) + (progn + (set-visited-file-modtime '(0 0)) + (setq buffer-file-name filename))) (list filename size)) (signal 'file-error (list "Opening input file" filename)))) - (ange-ftp-real-insert-file-contents filename visit beg end)))) + (ange-ftp-real-insert-file-contents filename visit beg end replace)))) (defun ange-ftp-expand-symlink (file dir) (if (file-name-absolute-p file) @@ -3026,7 +3087,7 @@ system TYPE.") (ange-ftp-get-files directory))) files f) (setq directory (file-name-as-directory directory)) - (ange-ftp-save-match-data + (save-match-data (while tail (setq f (car tail) tail (cdr tail)) @@ -3201,7 +3262,9 @@ system TYPE.") (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))) + (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) @@ -3360,8 +3423,7 @@ system TYPE.") ;;;; File renaming support. ;;;; ------------------------------------------------------------ -(defun ange-ftp-rename-remote-to-remote (filename newname f-parsed t-parsed - binary) +(defun ange-ftp-rename-remote-to-remote (filename newname f-parsed t-parsed) "Rename remote file FILE to remote file NEWNAME." (let ((f-host (nth 0 f-parsed)) (f-user (nth 1 f-parsed)) @@ -3413,8 +3475,7 @@ system TYPE.") (setq filename (expand-file-name filename)) (setq newname (expand-file-name newname)) (let* ((f-parsed (ange-ftp-ftp-name filename)) - (t-parsed (ange-ftp-ftp-name newname)) - (binary (if (or f-parsed t-parsed) (ange-ftp-binary-file filename)))) + (t-parsed (ange-ftp-ftp-name newname))) (if (and (or f-parsed t-parsed) (or (not ok-if-already-exists) (numberp ok-if-already-exists))) @@ -3425,7 +3486,7 @@ system TYPE.") (if f-parsed (if t-parsed (ange-ftp-rename-remote-to-remote filename newname f-parsed - t-parsed binary) + t-parsed) (ange-ftp-rename-remote-to-local filename newname)) (if t-parsed (ange-ftp-rename-local-to-remote filename newname) @@ -3508,7 +3569,7 @@ system TYPE.") "/"))) ; / never in filename completion-ignored-extensions "\\|"))) - (ange-ftp-save-match-data + (save-match-data (or (ange-ftp-file-name-completion-1 file tbl ange-ftp-this-dir (function ange-ftp-file-entry-not-ignored-p)) @@ -3631,19 +3692,29 @@ system TYPE.") (let* ((fn1 (expand-file-name file)) (pa1 (ange-ftp-ftp-name fn1))) (if pa1 - (let* ((tmp1 (ange-ftp-make-tmp-name (car pa1))) - (bin1 (ange-ftp-binary-file fn1))) + (let ((tmp1 (ange-ftp-make-tmp-name (car pa1)))) (ange-ftp-copy-file-internal fn1 tmp1 t nil (format "Getting %s" fn1)) tmp1)))) -(defun ange-ftp-load (file &rest args) +(defun ange-ftp-load (file &optional noerror nomessage nosuffix) (if (ange-ftp-ftp-name file) - (let ((copy (ange-ftp-file-local-copy file))) - (unwind-protect - (apply 'load copy args) - (delete-file copy))) - (apply 'ange-ftp-real-load file args))) + (let ((tryfiles (if nosuffix + (list file) + (list (concat file ".elc") (concat file ".el") file))) + copy) + (while (and tryfiles (not copy)) + (condition-case error + (setq copy (ange-ftp-file-local-copy (car tryfiles))) + (ftp-error nil)) + (setq tryfiles (cdr tryfiles))) + (if copy + (unwind-protect + (funcall 'load copy noerror nomessage nosuffix) + (delete-file copy)) + (or noerror + (signal 'file-error (list "Cannot open load file" file))))) + (ange-ftp-real-load file noerror nomessage nosuffix))) ;; Calculate default-unhandled-directory for a given ange-ftp buffer. (defun ange-ftp-unhandled-file-name-directory (filename) @@ -3671,7 +3742,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (cdr (assq (ange-ftp-host-type (car parsed)) ange-ftp-make-compressed-filename-alist)))) (let* ((decision - (ange-ftp-save-match-data (funcall conversion-func name))) + (save-match-data (funcall conversion-func name))) (compressing (car decision)) (newfile (nth 1 decision))) (if compressing @@ -3747,6 +3818,12 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (ange-ftp-copy-file-internal tmp2 nfile t nil msg2)))) (ange-ftp-del-tmp-name tmp1) (ange-ftp-del-tmp-name tmp2)))) + +(defun ange-ftp-find-backup-file-name (fn) + ;; Either return the ordinary backup name, etc., + ;; or return nil meaning don't make a backup. + (if ange-ftp-make-backup-files + (ange-ftp-real-find-backup-file-name fn))) ;;; Define the handler for special file names ;;; that causes ange-ftp to be invoked. @@ -3755,16 +3832,16 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (defun ange-ftp-hook-function (operation &rest args) (let ((fn (get operation 'ange-ftp))) (if fn (apply fn args) - (let (file-name-handler-alist) - (apply operation args))))) + (ange-ftp-run-real-handler operation args)))) ;;; This regexp takes care of real ange-ftp file names (with a slash ;;; and colon). +;;; Don't allow the host name to end in a period--some systems use /.: ;;;###autoload -(or (assoc "^/[^/:]*[^/:]:" file-name-handler-alist) +(or (assoc "^/[^/:]*[^/:.]:" file-name-handler-alist) (setq file-name-handler-alist - (cons '("^/[^/:]*[^/:]:" . ange-ftp-hook-function) + (cons '("^/[^/:]*[^/:.]:" . ange-ftp-hook-function) file-name-handler-alist))) ;;; This regexp recognizes and absolute filenames with only one component, @@ -3819,6 +3896,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (put 'dired-uncache 'ange-ftp 'ange-ftp-dired-uncache) (put 'dired-compress-file 'ange-ftp 'ange-ftp-dired-compress-file) (put 'load 'ange-ftp 'ange-ftp-load) +(put 'find-backup-file-name 'ange-ftp 'ange-ftp-find-backup-file-name) ;; Turn off truename processing to save time. ;; Treat each name as its own truename. @@ -3831,93 +3909,75 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") ;;; Define ways of getting at unmodified Emacs primitives, ;;; turning off our handler. +(defun ange-ftp-run-real-handler (operation args) + (let ((inhibit-file-name-handlers + (cons 'ange-ftp-hook-function + (cons 'ange-ftp-completion-hook-function + (and (eq inhibit-file-name-operation operation) + inhibit-file-name-handlers)))) + (inhibit-file-name-operation operation)) + (apply operation args))) + (defun ange-ftp-real-file-name-directory (&rest args) - (let (file-name-handler-alist) - (apply 'file-name-directory args))) + (ange-ftp-run-real-handler 'file-name-directory args)) (defun ange-ftp-real-file-name-nondirectory (&rest args) - (let (file-name-handler-alist) - (apply 'file-name-nondirectory args))) + (ange-ftp-run-real-handler 'file-name-nondirectory args)) (defun ange-ftp-real-file-name-as-directory (&rest args) - (let (file-name-handler-alist) - (apply 'file-name-as-directory args))) + (ange-ftp-run-real-handler 'file-name-as-directory args)) (defun ange-ftp-real-directory-file-name (&rest args) - (let (file-name-handler-alist) - (apply 'directory-file-name args))) + (ange-ftp-run-real-handler 'directory-file-name args)) (defun ange-ftp-real-expand-file-name (&rest args) - (let (file-name-handler-alist) - (apply 'expand-file-name args))) + (ange-ftp-run-real-handler 'expand-file-name args)) (defun ange-ftp-real-make-directory (&rest args) - (let (file-name-handler-alist) - (apply 'make-directory args))) + (ange-ftp-run-real-handler 'make-directory args)) (defun ange-ftp-real-delete-directory (&rest args) - (let (file-name-handler-alist) - (apply 'delete-directory args))) + (ange-ftp-run-real-handler 'delete-directory args)) (defun ange-ftp-real-insert-file-contents (&rest args) - (let (file-name-handler-alist) - (apply 'insert-file-contents args))) + (ange-ftp-run-real-handler 'insert-file-contents args)) (defun ange-ftp-real-directory-files (&rest args) - (let (file-name-handler-alist) - (apply 'directory-files args))) + (ange-ftp-run-real-handler 'directory-files args)) (defun ange-ftp-real-file-directory-p (&rest args) - (let (file-name-handler-alist) - (apply 'file-directory-p args))) + (ange-ftp-run-real-handler 'file-directory-p args)) (defun ange-ftp-real-file-writable-p (&rest args) - (let (file-name-handler-alist) - (apply 'file-writable-p args))) + (ange-ftp-run-real-handler 'file-writable-p args)) (defun ange-ftp-real-file-readable-p (&rest args) - (let (file-name-handler-alist) - (apply 'file-readable-p args))) + (ange-ftp-run-real-handler 'file-readable-p args)) (defun ange-ftp-real-file-executable-p (&rest args) - (let (file-name-handler-alist) - (apply 'file-executable-p args))) + (ange-ftp-run-real-handler 'file-executable-p args)) (defun ange-ftp-real-file-symlink-p (&rest args) - (let (file-name-handler-alist) - (apply 'file-symlink-p args))) + (ange-ftp-run-real-handler 'file-symlink-p args)) (defun ange-ftp-real-delete-file (&rest args) - (let (file-name-handler-alist) - (apply 'delete-file args))) + (ange-ftp-run-real-handler 'delete-file args)) (defun ange-ftp-real-read-file-name-internal (&rest args) - (let (file-name-handler-alist) - (apply 'read-file-name-internal args))) + (ange-ftp-run-real-handler 'read-file-name-internal args)) (defun ange-ftp-real-verify-visited-file-modtime (&rest args) - (let (file-name-handler-alist) - (apply 'verify-visited-file-modtime args))) + (ange-ftp-run-real-handler 'verify-visited-file-modtime args)) (defun ange-ftp-real-file-exists-p (&rest args) - (let (file-name-handler-alist) - (apply 'file-exists-p args))) + (ange-ftp-run-real-handler 'file-exists-p args)) (defun ange-ftp-real-write-region (&rest args) - (let (file-name-handler-alist) - (apply 'write-region args))) + (ange-ftp-run-real-handler 'write-region args)) (defun ange-ftp-real-backup-buffer (&rest args) - (let (file-name-handler-alist) - (apply 'backup-buffer args))) + (ange-ftp-run-real-handler 'backup-buffer args)) (defun ange-ftp-real-copy-file (&rest args) - (let (file-name-handler-alist) - (apply 'copy-file args))) + (ange-ftp-run-real-handler 'copy-file args)) (defun ange-ftp-real-rename-file (&rest args) - (let (file-name-handler-alist) - (apply 'rename-file args))) + (ange-ftp-run-real-handler 'rename-file args)) (defun ange-ftp-real-file-attributes (&rest args) - (let (file-name-handler-alist) - (apply 'file-attributes args))) + (ange-ftp-run-real-handler 'file-attributes args)) (defun ange-ftp-real-file-name-all-completions (&rest args) - (let (file-name-handler-alist) - (apply 'file-name-all-completions args))) + (ange-ftp-run-real-handler 'file-name-all-completions args)) (defun ange-ftp-real-file-name-completion (&rest args) - (let (file-name-handler-alist) - (apply 'file-name-completion args))) + (ange-ftp-run-real-handler 'file-name-completion args)) (defun ange-ftp-real-insert-directory (&rest args) - (let (file-name-handler-alist) - (apply 'insert-directory args))) + (ange-ftp-run-real-handler 'insert-directory args)) (defun ange-ftp-real-file-name-sans-versions (&rest args) - (let (file-name-handler-alist) - (apply 'file-name-sans-versions args))) + (ange-ftp-run-real-handler 'file-name-sans-versions args)) (defun ange-ftp-real-shell-command (&rest args) - (let (file-name-handler-alist) - (apply 'shell-command args))) + (ange-ftp-run-real-handler 'shell-command args)) (defun ange-ftp-real-load (&rest args) - (let (file-name-handler-alist) - (apply 'load args))) + (ange-ftp-run-real-handler 'load args)) +(defun ange-ftp-real-find-backup-file-name (&rest args) + (ange-ftp-run-real-handler 'find-backup-file-name args)) ;; Here we support using dired on remote hosts. ;; I have turned off the support for using dired on foreign directory formats. @@ -3933,7 +3993,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (defun ange-ftp-insert-directory (file switches &optional wildcard full) (let ((short (ange-ftp-abbreviate-filename file)) - (parsed (ange-ftp-ftp-name file))) + (parsed (ange-ftp-ftp-name (expand-file-name file)))) (if parsed (insert (if wildcard @@ -3960,12 +4020,6 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (if func (funcall func file keep-backup-version) (ange-ftp-real-file-name-sans-versions file keep-backup-version)))) -(defvar ange-ftp-remote-shell-file-name - (if (memq system-type '(hpux usg-unix-v)) ; hope that's right - "remsh" - "rsh") - "Name of command to run a remote shell, for ange-ftp.") - ;;; This doesn't work yet; a new hook needs to be created. ;;; Maybe the new hook should be in call-process. (defun ange-ftp-shell-command (command) @@ -3980,7 +4034,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (setq command (format "%s %s \"%s\"" ; remsh -l USER does not work well ; on a hp-ux machine I tried - ange-ftp-remote-shell-file-name host command)) + remote-shell-program host command)) (ange-ftp-message "Remote command '%s' ..." command) ;; Cannot call ange-ftp-real-dired-run-shell-command here as it ;; would prepend "cd default-directory" --- which bombs because @@ -4344,7 +4398,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") ; ;(defun ange-ftp-vos-host (host) ; (and ange-ftp-vos-host-regexp -; (ange-ftp-save-match-data +; (save-match-data ; (string-match ange-ftp-vos-host-regexp host)))) ; ;(defun ange-ftp-parse-vos-listing () @@ -4356,7 +4410,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") ; ("^Dirs: [0-9]+\n+" t 30))) ; type-regexp type-is-dir type-col file) ; (goto-char (point-min)) -; (ange-ftp-save-match-data +; (save-match-data ; (while type-list ; (setq type-regexp (car (car type-list)) ; type-is-dir (nth 1 (car type-list)) @@ -4387,7 +4441,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") ;; Convert NAME from UNIX-ish to VMS. If REVERSE given then convert from VMS ;; to UNIX-ish. (defun ange-ftp-fix-name-for-vms (name &optional reverse) - (ange-ftp-save-match-data + (save-match-data (if reverse (if (string-match "^\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)$" name) (let (drive dir file) @@ -4473,7 +4527,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") ;; Return non-nil if HOST is running VMS. (defun ange-ftp-vms-host (host) (and ange-ftp-vms-host-regexp - (ange-ftp-save-match-data + (save-match-data (string-match ange-ftp-vms-host-regexp host)))) ;; Because some VMS ftp servers convert filenames to lower case @@ -4481,8 +4535,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (defconst ange-ftp-vms-filename-regexp (concat - "\\(\\([_A-Za-z0-9$]?\\|[_A-Za-z0-9$][_A-Za-z0-9$---]*\\)\\." - "[_A-Za-z0-9$---]*;+[0-9]*\\)") + "\\(\\([_A-Za-z0-9$]?\\|[_A-Za-z0-9$][-_A-Za-z0-9$]*\\)\\." + "[-_A-Za-z0-9$]*;+[0-9]*\\)") "Regular expression to match for a valid VMS file name in Dired buffer. Stupid freaking bug! Position of _ and $ shouldn't matter but they do. Having [A-Z0-9$_] bombs on filename _$$CHANGE_LOG$.TXT$ and $CHANGE_LOG$.TX @@ -4507,7 +4561,7 @@ Other orders of $ and _ seem to all work just fine.") (let ((tbl (ange-ftp-make-hashtable)) file) (goto-char (point-min)) - (ange-ftp-save-match-data + (save-match-data (while (setq file (ange-ftp-parse-vms-filename)) (if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file) ;; deal with directories @@ -4541,7 +4595,7 @@ Other orders of $ and _ seem to all work just fine.") (defun ange-ftp-vms-delete-file-entry (name &optional dir-p) (if dir-p (ange-ftp-internal-delete-file-entry name t) - (ange-ftp-save-match-data + (save-match-data (let ((file (ange-ftp-get-file-part name))) (if (string-match ";[0-9]+$" file) ;; In VMS you can't delete a file without an explicit @@ -4582,7 +4636,7 @@ Other orders of $ and _ seem to all work just fine.") ange-ftp-files-hashtable))) (if files (let ((file (ange-ftp-get-file-part name))) - (ange-ftp-save-match-data + (save-match-data (if (string-match ";[0-9]+$" file) (ange-ftp-put-hash-entry (substring file 0 (match-beginning 0)) @@ -4631,7 +4685,7 @@ Other orders of $ and _ seem to all work just fine.") (defun ange-ftp-vms-file-name-as-directory (name) - (ange-ftp-save-match-data + (save-match-data (if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?$" name) (setq name (substring name 0 (match-beginning 0)))) (ange-ftp-real-file-name-as-directory name))) @@ -4792,8 +4846,8 @@ Other orders of $ and _ seem to all work just fine.") ;; (cons '(vms . ange-ftp-dired-vms-ls-trim) ;; ange-ftp-dired-ls-trim-alist))) -(defun ange-ftp-vms-sans-version (name) - (ange-ftp-save-match-data +(defun ange-ftp-vms-sans-version (name &rest args) + (save-match-data (if (string-match ";[0-9]+$" name) (substring name 0 (match-beginning 0)) name))) @@ -4950,7 +5004,7 @@ Other orders of $ and _ seem to all work just fine.") ;; Convert NAME from UNIX-ish to MTS. If REVERSE given then convert from ;; MTS to UNIX-ish. (defun ange-ftp-fix-name-for-mts (name &optional reverse) - (ange-ftp-save-match-data + (save-match-data (if reverse (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" name) (let (acct file) @@ -5000,14 +5054,14 @@ Other orders of $ and _ seem to all work just fine.") ;; Return non-nil if HOST is running MTS. (defun ange-ftp-mts-host (host) (and ange-ftp-mts-host-regexp - (ange-ftp-save-match-data + (save-match-data (string-match ange-ftp-mts-host-regexp host)))) ;; Parse the current buffer which is assumed to be in mts ftp dir format. (defun ange-ftp-parse-mts-listing () (let ((tbl (ange-ftp-make-hashtable))) (goto-char (point-min)) - (ange-ftp-save-match-data + (save-match-data (while (re-search-forward ange-ftp-date-regexp nil t) (end-of-line) (skip-chars-backward " ") @@ -5113,7 +5167,7 @@ Other orders of $ and _ seem to all work just fine.") ;; Have I got the filename character set right? (defun ange-ftp-fix-name-for-cms (name &optional reverse) - (ange-ftp-save-match-data + (save-match-data (if reverse ;; Since we only convert output from a pwd in this direction, ;; we'll assume that it's a minidisk, and make it into a @@ -5203,7 +5257,7 @@ Other orders of $ and _ seem to all work just fine.") ;; Return non-nil if HOST is running CMS. (defun ange-ftp-cms-host (host) (and ange-ftp-cms-host-regexp - (ange-ftp-save-match-data + (save-match-data (string-match ange-ftp-cms-host-regexp host)))) (defun ange-ftp-add-cms-host (host) @@ -5240,7 +5294,7 @@ Other orders of $ and _ seem to all work just fine.") ;; Now do the usual parsing (let ((tbl (ange-ftp-make-hashtable))) (goto-char (point-min)) - (ange-ftp-save-match-data + (save-match-data (while (re-search-forward "^\\([-A-Z0-9$_]+\\) +\\([-A-Z0-9$_]+\\) +[VF] +[0-9]+ " nil t)