From: Michael Albinus Date: Tue, 3 Nov 2020 17:47:32 +0000 (+0100) Subject: Some Tramp fixes for directory-files-* and delete-* X-Git-Tag: emacs-28.0.90~5261 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=2fffc1dfdff0a37f826a67d90d8a97091207dcb2;p=emacs.git Some Tramp fixes for directory-files-* and delete-* * lisp/files.el (delete-directory): Simplify check for trash. * lisp/net/ange-ftp.el (ange-ftp-delete-file): Implement TRASH. * lisp/net/tramp-compat.el (tramp-compat-directory-files) (tramp-compat-directory-files-and-attributes) (tramp-compat-directory-empty-p): New defaliases. * lisp/net/tramp.el (tramp-handle-directory-files-and-attributes) (tramp-skeleton-delete-directory): * lisp/net/tramp-gvfs.el (tramp-gvfs-handle-delete-directory): Use them. * lisp/net/tramp-sh.el (tramp-sh-handle-directory-files-and-attributes): Implement COUNT. * test/lisp/net/tramp-tests.el (tramp-test14-delete-directory): Do not run trash test for ange-ftp. (tramp-test16-directory-files) (tramp-test19-directory-files-and-attributes): Check COUNT argument. --- diff --git a/lisp/files.el b/lisp/files.el index e55552a2d9a..deb878cf418 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -5867,10 +5867,7 @@ RECURSIVE if DIRECTORY is nonempty." ;; case, where the operation fails in delete-directory-internal. ;; As `move-file-to-trash' trashes directories (empty or ;; otherwise) as a unit, we do not need to recurse here. - (if (and (not recursive) - ;; Check if directory is empty apart from "." and "..". - (directory-files - directory 'full directory-files-no-dot-files-regexp)) + (if (not (or recursive (directory-empty-p directory))) (error "Directory is not empty, not moving to trash") (move-file-to-trash directory))) ;; Otherwise, call ourselves recursively if needed. diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index 15322219eff..e0c162df577 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -3536,20 +3536,22 @@ system TYPE.") (setq file (expand-file-name file)) (let ((parsed (ange-ftp-ftp-name file))) (if parsed - (let* ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (name (ange-ftp-quote-string (nth 2 parsed))) - (abbr (ange-ftp-abbreviate-filename file)) - (result (ange-ftp-send-cmd host user - (list 'delete name) - (format "Deleting %s" abbr)))) - (or (car result) - (signal 'ftp-error - (list - "Removing old name" - (format "FTP Error: \"%s\"" (cdr result)) - file))) - (ange-ftp-delete-file-entry file)) + (if (and delete-by-moving-to-trash trash) + (move-file-to-trash file) + (let* ((host (nth 0 parsed)) + (user (nth 1 parsed)) + (name (ange-ftp-quote-string (nth 2 parsed))) + (abbr (ange-ftp-abbreviate-filename file)) + (result (ange-ftp-send-cmd host user + (list 'delete name) + (format "Deleting %s" abbr)))) + (or (car result) + (signal 'ftp-error + (list + "Removing old name" + (format "FTP Error: \"%s\"" (cdr result)) + file))) + (ange-ftp-delete-file-entry file))) (ange-ftp-real-delete-file file trash)))) (defun ange-ftp-file-modtime (file) @@ -4163,45 +4165,55 @@ directory, so that Emacs will know its current contents." (defun ange-ftp-delete-directory (dir &optional recursive trash) (if (file-directory-p dir) - (let ((parsed (ange-ftp-ftp-name dir))) - (if recursive - (mapc - (lambda (file) - (if (file-directory-p file) - (ange-ftp-delete-directory file recursive trash) - (delete-file file trash))) - (directory-files dir 'full directory-files-no-dot-files-regexp))) - (if parsed - (let* ((host (nth 0 parsed)) - (user (nth 1 parsed)) - ;; Some ftp's on unix machines (at least on Suns) - ;; insist that rmdir take a filename, and not a - ;; directory-name name as an arg. Argh!! This is a bug. - ;; Non-unix machines will probably always insist - ;; that rmdir takes a directory-name as an arg - ;; (as the ftp man page says it should). - (name (ange-ftp-quote-string - (if (eq (ange-ftp-host-type host) 'unix) - (ange-ftp-real-directory-file-name - (nth 2 parsed)) - (ange-ftp-real-file-name-as-directory - (nth 2 parsed))))) - (abbr (ange-ftp-abbreviate-filename dir)) - (result - (progn - ;; CWD must not in this directory. - (ange-ftp-cd host user "/" 'noerror) - (ange-ftp-send-cmd host user - (list 'rmdir name) - (format "Removing directory %s" - abbr))))) - (or (car result) - (ange-ftp-error host user - (format "Could not remove directory %s: %s" - dir - (cdr result)))) - (ange-ftp-delete-file-entry dir t)) - (ange-ftp-real-delete-directory dir recursive trash))) + ;; Trashing directories does not work yet, because + ;; `rename-file', called in `move-file-to-trash', does not + ;; handle directories. + (if nil ; (and delete-by-moving-to-trash trash) + ;; Move non-empty dir to trash only if recursive deletion was + ;; requested. + (if (not (or recursive (directory-empty-p dir))) + (signal 'ftp-error + (list "Directory is not empty, not moving to trash")) + (move-file-to-trash dir)) + (let ((parsed (ange-ftp-ftp-name dir))) + (if recursive + (mapc + (lambda (file) + (if (file-directory-p file) + (ange-ftp-delete-directory file recursive) + (delete-file file))) + (directory-files dir 'full directory-files-no-dot-files-regexp))) + (if parsed + (let* ((host (nth 0 parsed)) + (user (nth 1 parsed)) + ;; Some ftp's on unix machines (at least on Suns) + ;; insist that rmdir take a filename, and not a + ;; directory-name name as an arg. Argh!! This is a bug. + ;; Non-unix machines will probably always insist + ;; that rmdir takes a directory-name as an arg + ;; (as the ftp man page says it should). + (name (ange-ftp-quote-string + (if (eq (ange-ftp-host-type host) 'unix) + (ange-ftp-real-directory-file-name + (nth 2 parsed)) + (ange-ftp-real-file-name-as-directory + (nth 2 parsed))))) + (abbr (ange-ftp-abbreviate-filename dir)) + (result + (progn + ;; CWD must not in this directory. + (ange-ftp-cd host user "/" 'noerror) + (ange-ftp-send-cmd host user + (list 'rmdir name) + (format "Removing directory %s" + abbr))))) + (or (car result) + (ange-ftp-error host user + (format "Could not remove directory %s: %s" + dir + (cdr result)))) + (ange-ftp-delete-file-entry dir t)) + (ange-ftp-real-delete-directory dir recursive trash)))) (error "Not a directory: %s" dir))) ;; Make a local copy of FILE and return its name. diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index c554a8d0c2d..9a4e16efe20 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -309,6 +309,30 @@ A nil value for either argument stands for the current time." (lambda (filename &optional timestamp _flag) (set-file-times filename timestamp)))) +;; `directory-files' and `directory-files-and-attributes' got argument +;; COUNT in Emacs 28.1. +(defalias 'tramp-compat-directory-files + (if (equal (tramp-compat-funcall 'func-arity #'directory-files) '(1 . 5)) + #'directory-files + (lambda (directory &optional full match nosort _count) + (directory-files directory full match nosort)))) + +(defalias 'tramp-compat-directory-files-and-attributes + (if (equal (tramp-compat-funcall 'func-arity #'directory-files-and-attributes) + '(1 . 6)) + #'directory-files-and-attributes + (lambda (directory &optional full match nosort id-format _count) + (directory-files-and-attributes directory full match nosort id-format)))) + +;; `directory-empty-p' is new in Emacs 28.1. +(defalias 'tramp-compat-directory-empty-p + (if (fboundp 'directory-empty-p) + #'directory-empty-p + (lambda (dir) + (and (file-directory-p dir) + (null (tramp-compat-directory-files + dir nil directory-files-no-dot-files-regexp t 1)))))) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-loaddefs 'force) @@ -322,5 +346,8 @@ A nil value for either argument stands for the current time." ;; ;; * Starting with Emacs 27.1, there's no need to escape open ;; parentheses with a backslash in docstrings anymore. +;; +;; * Starting with Emacs 27.1, there's `make-empty-file'. Could be +;; used instead of `write-region'. ;;; tramp-compat.el ends here diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index bf55777e335..86fb45a43b7 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -1088,7 +1088,7 @@ file names." (delete-file file))) (directory-files directory 'full directory-files-no-dot-files-regexp)) - (when (directory-files directory nil directory-files-no-dot-files-regexp) + (unless (tramp-compat-directory-empty-p directory) (tramp-error v 'file-error "Couldn't delete non-empty %s" directory))) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 915ce2f6a65..655949a79b8 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1738,6 +1738,9 @@ ID-FORMAT valid values are `string' and `integer'." (setcar item (expand-file-name (car item) directory))) (push item result))) + (when (natnump count) + (setq result (last result count))) + (or (if nosort result (sort result (lambda (x y) (string< (car x) (car y))))) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index ce0a2b54ff5..1859e843758 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3145,7 +3145,7 @@ User is always nil." (lambda (x) (cons x (file-attributes (if full x (expand-file-name x directory)) id-format))) - (directory-files directory full match nosort count))) + (tramp-compat-directory-files directory full match nosort count))) (defun tramp-handle-dired-uncache (dir) "Like `dired-uncache' for Tramp files." @@ -5346,9 +5346,7 @@ BODY is the backend specific code." (if (and delete-by-moving-to-trash ,trash) ;; Move non-empty dir to trash only if recursive deletion was ;; requested. - (if (and (not ,recursive) - (directory-files - ,directory nil directory-files-no-dot-files-regexp)) + (if (not (or ,recursive (tramp-compat-directory-empty-p ,directory))) (tramp-error v 'file-error "Directory is not empty, not moving to trash") (move-file-to-trash ,directory)) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 50db55ebb4f..2670723ecdc 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2783,8 +2783,9 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (should-not (file-directory-p tmp-name1)) ;; Trashing directories works only since Emacs 27.1. It doesn't - ;; work for crypted remote directories. - (when (and (not (tramp--test-crypt-p)) (tramp--test-emacs27-p)) + ;; work for crypted remote directories and for ange-ftp. + (when (and (not (tramp--test-crypt-p)) (not (tramp--test-ftp-p)) + (tramp--test-emacs27-p)) (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) (delete-by-moving-to-trash t)) (make-directory trash-directory) @@ -2925,7 +2926,15 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." '("bla" "foo"))) (should (equal (directory-files tmp-name1 'full directory-files-no-dot-files-regexp) - `(,tmp-name2 ,tmp-name3)))) + `(,tmp-name2 ,tmp-name3))) + ;; Check the COUNT arg. It exists since Emacs 28. + (when (tramp--test-emacs28-p) + (with-no-warnings + (should + (= 1 (length + (directory-files + tmp-name1 nil directory-files-no-dot-files-regexp + nil 1))))))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive)))))) @@ -3443,7 +3452,13 @@ They might differ only in time attributes or directory size." (file-attributes (car elt)) (cdr elt)))) (setq attr (directory-files-and-attributes tmp-name2 nil "\\`b")) - (should (equal (mapcar #'car attr) '("bar" "boz")))) + (should (equal (mapcar #'car attr) '("bar" "boz"))) + + ;; Check the COUNT arg. It exists since Emacs 28. + (when (tramp--test-emacs28-p) + (with-no-warnings + (should (= 1 (length (directory-files-and-attributes + tmp-name2 nil "\\`b" nil nil 1))))))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive))))))