From: Tino Calancha <tino.calancha@gmail.com>
To: Michael Albinus <michael.albinus@gmx.de>
Cc: uyennhi.qm@gmail.com, 50581@debbugs.gnu.org
Subject: bug#50581: 27.2.50; Tramp fails to (un)compress directories
Date: Sun, 19 Sep 2021 18:50:38 +0200 [thread overview]
Message-ID: <87wnnc7bmp.fsf@calancha-pc.dy.bbexcite.jp> (raw)
In-Reply-To: <87sfy7ov5m.fsf@gmx.de> (Michael Albinus's message of "Tue, 14 Sep 2021 20:43:17 +0200")
Michael Albinus <michael.albinus@gmx.de> writes:
> Indeed, the directory case is not implemented in tramp-sh-handle-dired-compress-file.
> I will see how to implement it next time.
I have mimic what `dired-compress-file' does: it checks if the
file is a directory.
--8<-----------------------------cut here---------------start------------->8---
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index fbb122e721..54256253b1 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -2498,9 +2498,13 @@ tramp-sh-handle-dired-compress-file
(with-tramp-progress-reporter
v 0 (format "Uncompressing %s" file)
(when (tramp-send-command-and-check
- v (concat (nth 2 suffix) " "
- (tramp-shell-quote-argument localname)))
- (dired-remove-file file)
+ v (if (string-match-p "%[io]" (nth 2 suffix))
+ (replace-regexp-in-string
+ "%i" (tramp-shell-quote-argument localname)
+ (nth 2 suffix))
+ (concat (nth 2 suffix) " " (tramp-shell-quote-argument localname))))
+ (unless (string-match-p "\\.tar\\.gz" file)
+ (dired-remove-file file))
(string-match (car suffix) file)
(concat (substring file 0 (match-beginning 0))))))
(t
@@ -2508,14 +2512,19 @@ tramp-sh-handle-dired-compress-file
;; Try gzip.
(with-tramp-progress-reporter v 0 (format "Compressing %s" file)
(when (tramp-send-command-and-check
- v (concat "gzip -f "
- (tramp-shell-quote-argument localname)))
- (dired-remove-file file)
- (cond ((file-exists-p (concat file ".gz"))
- (concat file ".gz"))
- ((file-exists-p (concat file ".z"))
- (concat file ".z"))
- (t nil)))))))))
+ v (if (file-directory-p file)
+ (format "tar -cf - %s | gzip -c9 > %s.tar.gz"
+ (tramp-shell-quote-argument (file-name-nondirectory localname))
+ (tramp-shell-quote-argument localname))
+ (concat "gzip -f "
+ (tramp-shell-quote-argument localname))))
+ (unless (file-directory-p file)
+ (dired-remove-file file))
+ (catch 'found nil
+ (dolist (target (mapcar (lambda (suffix) (concat file suffix))
+ '(".tar.gz" ".gz" ".z")))
+ (when (file-exists-p target)
+ (throw 'found target)))))))))))
(defun tramp-sh-handle-insert-directory
(filename switches &optional wildcard full-directory-p)
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index 9f0264abc1..b0b61ad8f0 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -61,6 +61,7 @@
(declare-function tramp-list-tramp-buffers "tramp-cmds")
(declare-function tramp-method-out-of-band-p "tramp-sh")
(declare-function tramp-smb-get-localname "tramp-smb")
+(declare-function dired-compress "dired-aux")
(defvar ange-ftp-make-backup-files)
(defvar auto-save-file-name-transforms)
(defvar lock-file-name-transforms)
@@ -7079,6 +7080,36 @@ tramp--test-with-proper-process-name-and-buffer
(ignore-errors (all-completions "tramp" (symbol-value x)))
(ert-fail (format "Hook `%s' still contains Tramp function" x))))))
+(ert-deftest tramp-test47-dired-compress-file ()
+ "Check that Tramp (un)compress normal files."
+ (skip-unless (tramp--test-enabled))
+ (let ((default-directory tramp-test-temporary-file-directory)
+ (tmp-name (tramp--test-make-temp-name)))
+ (write-region "foo" nil tmp-name)
+ (dired default-directory)
+ (dired-revert)
+ (dired-goto-file tmp-name)
+ (should-not (dired-compress))
+ (should (string= (concat tmp-name ".gz") (dired-get-filename)))
+ (should-not (dired-compress))
+ (should (string= tmp-name (dired-get-filename)))
+ (delete-file tmp-name)))
+
+(ert-deftest tramp-test47-dired-compress-dir ()
+ "Check that Tramp (un)compress directories."
+ (skip-unless (tramp--test-enabled))
+ (let ((default-directory tramp-test-temporary-file-directory)
+ (tmp-name (tramp--test-make-temp-name)))
+ (make-directory tmp-name)
+ (dired default-directory)
+ (dired-revert)
+ (dired-goto-file tmp-name)
+ (should-not (dired-compress))
+ (should (string= (concat tmp-name ".tar.gz") (dired-get-filename)))
+ (should-not (dired-compress))
+ (should (string= tmp-name (dired-get-filename)))
+ (delete-directory tmp-name)))
+
(defun tramp-test-all (&optional interactive)
"Run all tests for \\[tramp].
If INTERACTIVE is non-nil, the tests are run interactively."
--8<-----------------------------cut here---------------end--------------->8---
In GNU Emacs 28.0.50 (build 6, x86_64-pc-linux-gnu, GTK+ Version 3.24.5, cairo version 1.16.0)
Repository revision: 7abbf3779cf88c59a9c20526464974213db63fdb
Repository branch: master
Windowing system distributor 'The X.Org Foundation', version 11.0.12004000
System Description: Debian GNU/Linux 10 (buster)
next prev parent reply other threads:[~2021-09-19 16:50 UTC|newest]
Thread overview: 5+ messages / expand[flat|nested] mbox.gz Atom feed top
2021-09-14 12:53 bug#50581: 27.2.50; Tramp fails to (un)compress directories Tino Calancha
2021-09-14 18:43 ` Michael Albinus
2021-09-19 16:50 ` Tino Calancha [this message]
2021-09-20 12:50 ` Michael Albinus
2021-11-05 3:36 ` Lars Ingebrigtsen
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87wnnc7bmp.fsf@calancha-pc.dy.bbexcite.jp \
--to=tino.calancha@gmail.com \
--cc=50581@debbugs.gnu.org \
--cc=michael.albinus@gmx.de \
--cc=uyennhi.qm@gmail.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).