master 2fffc1d: Some Tramp fixes for directory-files-* and delete-*

[Michael Albinus]

branch: master
commit 2fffc1dfdff0a37f826a67d90d8a97091207dcb2
Author: Michael Albinus <michael.albinus@gmx.de>
Commit: Michael Albinus <michael.albinus@gmx.de>

    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.
---
 lisp/files.el                |   5 +-
 lisp/net/ange-ftp.el         | 118 ++++++++++++++++++++++++-------------------
 lisp/net/tramp-compat.el     |  27 ++++++++++
 lisp/net/tramp-gvfs.el       |   2 +-
 lisp/net/tramp-sh.el         |   3 ++
 lisp/net/tramp.el            |   6 +--
 test/lisp/net/tramp-tests.el |  23 +++++++--
 7 files changed, 118 insertions(+), 66 deletions(-)

diff --git a/lisp/files.el b/lisp/files.el
index e55552a..deb878c 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 1532221..e0c162d 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 c554a8d..9a4e16e 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 bf55777..86fb45a 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 915ce2f..655949a 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 ce0a2b5..1859e84 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 50db55e..2670723 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))))))