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.
2017-08-12 12:30:39 +02:00 · 2017-08-12 12:30:39 +02:00 · ec5cfaa456
commit ec5cfaa456
parent e94b0d4d54
10 changed files with 82 additions and 57 deletions
--- 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

--- 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))
--- 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)
--- 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
--- 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)
--- 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)
--- 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)
--- 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)
 	{
--- 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));
--- 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))))))