[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master ec5cfaa: Implement EXCL of write-region for Tramp
From: |
Michael Albinus |
Subject: |
[Emacs-diffs] master ec5cfaa: Implement EXCL of write-region for Tramp |
Date: |
Sat, 12 Aug 2017 06:30:46 -0400 (EDT) |
branch: master
commit ec5cfaa4568327b5b0b299be2664f7fdae123292
Author: Michael Albinus <address@hidden>
Commit: Michael Albinus <address@hidden>
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 0670a7b..3f38153 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 ecb60e5..ebc1469 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 3469790..6e662df 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 4c750df..48f50a3 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 4beb6fe..6b365c1 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 1aadd14..367beb8 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 fe2708b..e3e7d8e 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 8506a19..31fd845 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 4de6fc8..25be5c0 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 50dfd6f..45cf95f 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))))))
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] master ec5cfaa: Implement EXCL of write-region for Tramp,
Michael Albinus <=