;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
(defun ange-ftp-quote-string (string)
"Quote any characters in STRING that may confuse the ftp process."
- (apply 'concat
- (mapcar (lambda (char)
- ;; This is said to be wrong; ftp is said to
- ;; need quoting only for ", and that by doubling it.
- ;; But experiment says this kind of quoting is correct
- ;; when talking to ftp on GNU/Linux systems.
- (if (or (<= char ? )
- (> char ?\~)
- (= char ?\")
- (= char ?\\))
- (vector ?\\ char)
- (vector char)))
- string)))
+ ;; This is said to be wrong; ftp is said to need quoting only for ",
+ ;; and that by doubling it. But experiment says UNIX-style kind of
+ ;; quoting is correct when talking to ftp on GNU/Linux systems, and
+ ;; W32-style kind of quoting on, yes, W32 systems.
+ (if (stringp string)
+ (shell-quote-argument string)
+ ""))
(defun ange-ftp-barf-if-not-directory (directory)
(or (file-directory-p directory)
(ange-ftp-send-cmd
t-host
t-user
- (list 'put (or temp2 filename) t-name)
+ (list 'put (or temp2 (ange-ftp-quote-string filename)) t-name)
(or msg
(if (and temp2 f-parsed)
(format "Putting %s" newname)
(ange-ftp-call-cont cont result line)))
(defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists
- keep-date)
+ keep-date preserve-uid-gid)
(interactive "fCopy file: \nFCopy %s to file: \np")
(ange-ftp-copy-file-internal filename
newname
(format "Getting %s" fn1))
tmp1))))
-(defun ange-ftp-file-remote-p (file)
- (ange-ftp-replace-name-component file ""))
+(defun ange-ftp-file-remote-p (file &optional identification connected)
+ (let* ((parsed (ange-ftp-ftp-name file))
+ (host (nth 0 parsed))
+ (user (nth 1 parsed)))
+ (and (or (not connected)
+ (let ((proc (get-process (ange-ftp-ftp-process-buffer host user))))
+ (and proc (processp proc)
+ (memq (process-status proc) '(run open)))))
+ (cond
+ ((eq identification 'method) (and parsed "ftp"))
+ ((eq identification 'user) user)
+ ((eq identification 'host) host)
+ (t (ange-ftp-replace-name-component file ""))))))
(defun ange-ftp-load (file &optional noerror nomessage nosuffix)
(if (ange-ftp-ftp-name file)
;; Calculate default-unhandled-directory for a given ange-ftp buffer.
(defun ange-ftp-unhandled-file-name-directory (filename)
- (file-name-directory ange-ftp-tmp-name-template))
+ nil)
\f
;; Need the following functions for making filenames of compressed
;; Treat each name as its own truename.
(put 'file-truename 'ange-ftp 'identity)
+;; We must return non-nil in order to mask our inability to do the job.
+;; Otherwise there are errors when applied to the target file during
+;; copying from a (localhost) Tramp file.
+(put 'set-file-modes 'ange-ftp 'ignore)
+(put 'set-file-times 'ange-ftp 'ignore)
+
;; Turn off RCS/SCCS processing to save time.
;; This returns nil for any file name as argument.
(put 'vc-registered 'ange-ftp 'null)
-(put 'dired-call-process 'ange-ftp 'ange-ftp-dired-call-process)
+;; We can handle process-file in a restricted way (just for chown).
+;; Nothing possible for `start-file-process'.
+(put 'process-file 'ange-ftp 'ange-ftp-process-file)
+(put 'start-file-process 'ange-ftp 'ignore)
(put 'shell-command 'ange-ftp 'ange-ftp-shell-command)
\f
;;; Define ways of getting at unmodified Emacs primitives,
;; default-directory is in ange-ftp syntax for remote file names.
(ange-ftp-real-shell-command command output-buffer error-buffer))))
-;;; This is the handler for call-process.
-(defun ange-ftp-dired-call-process (program discard &rest arguments)
+;;; This is the handler for process-file.
+(defun ange-ftp-process-file (program infile buffer display &rest arguments)
;; PROGRAM is always one of those below in the cond in dired.el.
;; The ARGUMENTS are (nearly) always files.
(if (ange-ftp-ftp-name default-directory)
1)
(error (insert (format "%s\n" (nth 1 oops)))
1))
- (apply 'call-process program nil (not discard) nil arguments)))
+ (apply 'call-process program infile buffer display arguments)))
;; Handle an attempt to run chmod on a remote file
;; by using the ftp chmod command.
(rest (cdr args)))
(if (equal "--" (car rest))
(setq rest (cdr rest)))
- (mapcar
+ (mapc
(lambda (file)
(setq file (expand-file-name file))
(let ((parsed (ange-ftp-ftp-name file)))
(puthash ".." t tbl)
;; add all additional pubsets, if not listing one of them
(if (not (member pubset ange-ftp-bs2000-additional-pubsets))
- (mapcar (lambda (pubset) (puthash pubset t tbl))
- ange-ftp-bs2000-additional-pubsets))
+ (mapc (lambda (pubset) (puthash pubset t tbl))
+ ange-ftp-bs2000-additional-pubsets))
tbl))
(add-to-list 'ange-ftp-parse-list-func-alist
HCoop / bpt / emacs.git / blobdiff