From ec5cfaa4568327b5b0b299be2664f7fdae123292 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 12 Aug 2017 12:30:39 +0200 Subject: [PATCH] Implement EXCL of write-region for Tramp * lisp/net/ange-ftp.el (ange-ftp-write-region): * lisp/net/tramp-adb.el (tramp-adb-handle-write-region) * lisp/net/tramp-gvfs.el (tramp-gvfs-handle-write-region): * lisp/net/tramp-sh.el (tramp-sh-handle-write-region) * lisp/net/tramp-smb.el (tramp-smb-handle-write-region): Implement MUSTBENEW. * lisp/net/tramp-gvfs.el (tramp-gvfs-do-copy-or-rename-file) * lisp/net/tramp-sh.el (tramp-sh-handle-make-symbolic-link) (tramp-sh-handle-add-name-to-file) (tramp-do-copy-or-rename-file) * lisp/net/tramp-smb.el (tramp-smb-handle-make-symbolic-link): Adapt error message for `file-already-exists'. * src/lisp.h: * src/eval.c (call8): New function. * src/fileio.c (write_region): Pass also lockname and mustbenew to the file name handler. * test/lisp/net/tramp-tests.el (tramp-test10-write-region): Add tests for MUSTBENEW. --- etc/NEWS | 4 ++++ lisp/net/ange-ftp.el | 6 +++++- lisp/net/tramp-adb.el | 16 +++++++++------- lisp/net/tramp-gvfs.el | 20 ++++++++++---------- lisp/net/tramp-sh.el | 36 ++++++++++++------------------------ lisp/net/tramp-smb.el | 23 +++++++++++------------ src/eval.c | 11 +++++++++++ src/fileio.c | 4 ++-- src/lisp.h | 1 + test/lisp/net/tramp-tests.el | 18 +++++++++++++++++- 10 files changed, 82 insertions(+), 57 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 0670a7bbf91..3f38153048c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1200,6 +1200,10 @@ particular, the function 'internal--module-call' has been removed. Code that depends on undocumented internals of the module system might break. +--- +** The arguments LOCKNAME and MUSTBENEW of 'write-region' are +propagated to file name handlers now. + * Lisp Changes in Emacs 26.1 diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index ecb60e5a4f4..ebc14693f65 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -3223,8 +3223,12 @@ system TYPE.") (defun ange-ftp-binary-file (file) (string-match-p ange-ftp-binary-file-name-regexp file)) -(defun ange-ftp-write-region (start end filename &optional append visit) +(defun ange-ftp-write-region + (start end filename &optional append visit _lockname mustbenew) (setq filename (expand-file-name filename)) + (when mustbenew + (ange-ftp-barf-or-query-if-file-exists + filename "overwrite" (not (eq mustbenew 'excl)))) (let ((parsed (ange-ftp-ftp-name filename))) (if parsed (let* ((host (nth 0 parsed)) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 346979000f5..6e662df6e29 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -630,14 +630,17 @@ But handle the case, if the \"test\" command is not available." rw-path))))))) (defun tramp-adb-handle-write-region - (start end filename &optional append visit lockname confirm) + (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (when (and confirm (file-exists-p filename)) - (unless (y-or-n-p (format "File %s exists; overwrite anyway? " - filename)) - (tramp-error v 'file-error "File not overwritten"))) + (when (and mustbenew (file-exists-p filename) + (or (eq mustbenew 'excl) + (not + (y-or-n-p + (format "File %s exists; overwrite anyway? " filename))))) + (tramp-error v 'file-already-exists filename)) + ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. (tramp-flush-file-property v (file-name-directory localname)) @@ -650,8 +653,7 @@ But handle the case, if the \"test\" command is not available." tmpfile (logior (or (file-modes tmpfile) 0) (string-to-number "0600" 8)))) (tramp-run-real-handler - 'write-region - (list start end tmpfile append 'no-message lockname confirm)) + 'write-region (list start end tmpfile append 'no-message lockname)) (with-tramp-progress-reporter v 3 (format-message "Moving tmp file `%s' to `%s'" tmpfile filename) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 4c750df3c40..48f50a3d05a 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -658,8 +658,7 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error - v 'file-already-exists "File %s already exists" newname)) + (tramp-error v 'file-already-exists newname)) (if (or (and equal-remote (tramp-get-connection-property v "direct-copy-failed" nil)) @@ -1172,12 +1171,16 @@ file-notify events." 'rename-file (list filename newname ok-if-already-exists)))) (defun tramp-gvfs-handle-write-region - (start end filename &optional append visit lockname confirm) + (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." + (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (when (and confirm (file-exists-p filename)) - (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename)) - (tramp-error v 'file-error "File not overwritten"))) + (when (and mustbenew (file-exists-p filename) + (or (eq mustbenew 'excl) + (not + (y-or-n-p + (format "File %s exists; overwrite anyway? " filename))))) + (tramp-error v 'file-already-exists filename)) (let ((tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) @@ -1186,10 +1189,7 @@ file-notify events." ;; modtime data to be clobbered from the temp file. We call ;; `set-visited-file-modtime' ourselves later on. (tramp-run-real-handler - 'write-region - (if confirm ; don't pass this arg unless defined for backward compat. - (list start end tmpfile append 'no-message lockname confirm) - (list start end tmpfile append 'no-message lockname))) + 'write-region (list start end tmpfile append 'no-message lockname)) (condition-case nil (rename-file tmpfile filename 'ok-if-already-exists) (error diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 4beb6fe5216..6b365c10e25 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1085,8 +1085,7 @@ target of the symlink differ." (format "File %s already exists; make it a link anyway? " l-localname))))) - (tramp-error - l 'file-already-exists "File %s already exists" l-localname) + (tramp-error l 'file-already-exists l-localname) (delete-file linkname))) ;; If FILENAME is a Tramp name, use just the localname component. @@ -1925,9 +1924,7 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" (format "File %s already exists; make it a new name anyway? " newname))) - (tramp-error - v2 'file-already-exists - "add-name-to-file: file %s already exists" newname)) + (tramp-error v2 'file-already-exists newname)) (when ok-if-already-exists (setq ln (concat ln " -f"))) (tramp-flush-file-property v2 (file-name-directory v2-localname)) (tramp-flush-file-property v2 v2-localname) @@ -2041,8 +2038,7 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error - v 'file-already-exists "File %s already exists" newname)) + (tramp-error v 'file-already-exists newname)) (with-tramp-progress-reporter v 0 (format "%s %s to %s" @@ -3150,23 +3146,16 @@ the result will be a local, non-Tramp, file name." ;; CCC grok LOCKNAME (defun tramp-sh-handle-write-region - (start end filename &optional append visit lockname confirm) + (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - ;; Following part commented out because we don't know what to do about - ;; file locking, and it does not appear to be a problem to ignore it. - ;; Ange-ftp ignores it, too. - ;; (when (and lockname (stringp lockname)) - ;; (setq lockname (expand-file-name lockname))) - ;; (unless (or (eq lockname nil) - ;; (string= lockname filename)) - ;; (error - ;; "tramp-sh-handle-write-region: LOCKNAME must be nil or equal FILENAME")) - - (when (and confirm (file-exists-p filename)) - (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename)) - (tramp-error v 'file-error "File not overwritten"))) + (when (and mustbenew (file-exists-p filename) + (or (eq mustbenew 'excl) + (not + (y-or-n-p + (format "File %s exists; overwrite anyway? " filename))))) + (tramp-error v 'file-already-exists filename)) (let ((uid (or (tramp-compat-file-attribute-user-id (file-attributes filename 'integer)) @@ -3185,8 +3174,7 @@ the result will be a local, non-Tramp, file name." (file-writable-p localname))))) ;; Short track: if we are on the local host, we can run directly. (tramp-run-real-handler - 'write-region - (list start end localname append 'no-message lockname confirm)) + 'write-region (list start end localname append 'no-message lockname)) (let* ((modes (save-excursion (tramp-default-file-modes filename))) ;; We use this to save the value of @@ -3223,7 +3211,7 @@ the result will be a local, non-Tramp, file name." (condition-case err (tramp-run-real-handler 'write-region - (list start end tmpfile append 'no-message lockname confirm)) + (list start end tmpfile append 'no-message lockname)) ((error quit) (setq tramp-temp-buffer-file-name nil) (delete-file tmpfile) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 1aadd14fb41..367beb823aa 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -137,6 +137,7 @@ call, letting the SMB client use the default one." "NT_STATUS_HOST_UNREACHABLE" "NT_STATUS_IMAGE_ALREADY_LOADED" "NT_STATUS_INVALID_LEVEL" + "NT_STATUS_INVALID_PARAMETER_MIX" "NT_STATUS_IO_TIMEOUT" "NT_STATUS_LOGON_FAILURE" "NT_STATUS_NETWORK_ACCESS_DENIED" @@ -1124,9 +1125,7 @@ target of the symlink differ." (format "File %s already exists; make it a new name anyway? " linkname))) - (tramp-error - v2 'file-already-exists - "make-symbolic-link: file %s already exists" linkname)) + (tramp-error v2 'file-already-exists linkname)) (unless (tramp-smb-get-cifs-capabilities v1) (tramp-error v2 'file-error "make-symbolic-link not supported")) ;; We must also flush the cache of the directory, because @@ -1469,14 +1468,17 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (error filename)))) (defun tramp-smb-handle-write-region - (start end filename &optional append visit lockname confirm) + (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (when (and confirm (file-exists-p filename)) - (unless (y-or-n-p (format "File %s exists; overwrite anyway? " - filename)) - (tramp-error v 'file-error "File not overwritten"))) + (when (and mustbenew (file-exists-p filename) + (or (eq mustbenew 'excl) + (not + (y-or-n-p + (format "File %s exists; overwrite anyway? " filename))))) + (tramp-error v 'file-already-exists filename)) + ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. (tramp-flush-file-property v (file-name-directory localname)) @@ -1489,10 +1491,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." ;; modtime data to be clobbered from the temp file. We call ;; `set-visited-file-modtime' ourselves later on. (tramp-run-real-handler - 'write-region - (if confirm ; don't pass this arg unless defined for backward compat. - (list start end tmpfile append 'no-message lockname confirm) - (list start end tmpfile append 'no-message lockname))) + 'write-region (list start end tmpfile append 'no-message lockname)) (with-tramp-progress-reporter v 3 (format "Moving tmp file %s to %s" tmpfile filename) diff --git a/src/eval.c b/src/eval.c index fe2708b1bbc..e3e7d8e26b2 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2660,6 +2660,17 @@ call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7); } +/* Call function fn with 8 arguments arg1, arg2, arg3, arg4, arg5, + arg6, arg7, arg8. */ +/* ARGSUSED */ +Lisp_Object +call8 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, + Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7, + Lisp_Object arg8) +{ + return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); +} + DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0, doc: /* Non-nil if OBJECT is a function. */) (Lisp_Object object) diff --git a/src/fileio.c b/src/fileio.c index 8506a198fe3..31fd84512e1 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -4852,8 +4852,8 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename, if (!NILP (handler)) { Lisp_Object val; - val = call6 (handler, Qwrite_region, start, end, - filename, append, visit); + val = call8 (handler, Qwrite_region, start, end, + filename, append, visit, lockname, mustbenew); if (visiting) { diff --git a/src/lisp.h b/src/lisp.h index 4de6fc85ec1..25be5c0ceea 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3846,6 +3846,7 @@ extern Lisp_Object call4 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Li extern Lisp_Object call5 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); extern Lisp_Object call6 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); extern Lisp_Object call7 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); +extern Lisp_Object call8 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); extern Lisp_Object internal_catch (Lisp_Object, Lisp_Object (*) (Lisp_Object), Lisp_Object); extern Lisp_Object internal_lisp_condition_case (Lisp_Object, Lisp_Object, Lisp_Object); extern Lisp_Object internal_condition_case (Lisp_Object (*) (void), Lisp_Object, Lisp_Object (*) (Lisp_Object)); diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 50dfd6fac2e..45cf95fcfe0 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -1846,7 +1846,23 @@ This checks also `file-name-as-directory', `file-name-directory', (write-region 3 5 tmp-name)) (with-temp-buffer (insert-file-contents tmp-name) - (should (string-equal (buffer-string) "34")))) + (should (string-equal (buffer-string) "34"))) + + ;; Do not overwrite if excluded. + (cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) t))) + (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) + ;; `mustbenew' is passed to Tramp since Emacs 26.1. We + ;; have no test for this, so we check function + ;; `temporary-file-directory', which has been added to + ;; Emacs 26.1 as well. + (when (fboundp 'temporary-file-directory) + (should-error + (cl-letf (((symbol-function 'y-or-n-p) 'ignore)) + (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) + :type 'file-already-exists) + (should-error + (write-region "foo" nil tmp-name nil nil nil 'excl) + :type 'file-already-exists))) ;; Cleanup. (ignore-errors (delete-file tmp-name)))))) -- 2.39.5