From d338325c2b603db8433c9b6b12216201d5ee21e9 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 9 Dec 2017 14:34:30 +0100 Subject: Support for archive file names * doc/misc/tramp.texi (Top, Usage): Add entry "Archive file names". (History): Mention archive file names. (GVFS based methods): Mentio "http" and "https" methods. (Archive file names): New node. (Frequently Asked Questions): Add Emacs 27 as supported version. * etc/NEWS: Mention tramp-archive.el. * lisp/net/tramp.el (tramp-run-real-handler) (tramp-register-file-name-handlers) (tramp-register-file-name-handlers, tramp-unload-file-name-handlers): Add `tramp-archive-file-name-handler'. (tramp-handle-file-name-completion): Do not insist in Tramp file names. * lisp/net/tramp-archive.el: New package. * lisp/net/tramp-cache.el (tramp-dump-connection-properties): Check for "archive" method. * lisp/net/tramp-cmds.el (tramp-cleanup-all-connections): Cleanup also local copies of archives. * lisp/net/tramp-compat.el (tramp-compat-use-url-tramp-p): New defconst. * lisp/net/tramp-gvfs.el (tramp-gvfs-methods): Add "http" and "https". (tramp-gvfs-gio-mapping): Add "gvfs-mount". (tramp-gvfs-handler-mounted-unmounted) (tramp-gvfs-connection-mounted-p, tramp-gvfs-mount-spec): Handle "uri" and "http". (tramp-gvfs-unmount): New defun. * test/lisp/net/tramp-archive-tests.el: New package. --- test/lisp/net/tramp-archive-resources/bar/bar | 1 + test/lisp/net/tramp-archive-resources/foo.hrd | 1 + test/lisp/net/tramp-archive-resources/foo.lnk | 1 + test/lisp/net/tramp-archive-resources/foo.tar.gz | Bin 0 -> 234 bytes test/lisp/net/tramp-archive-resources/foo.txt | 1 + 5 files changed, 4 insertions(+) create mode 100644 test/lisp/net/tramp-archive-resources/bar/bar create mode 100644 test/lisp/net/tramp-archive-resources/foo.hrd create mode 120000 test/lisp/net/tramp-archive-resources/foo.lnk create mode 100644 test/lisp/net/tramp-archive-resources/foo.tar.gz create mode 100644 test/lisp/net/tramp-archive-resources/foo.txt (limited to 'test/lisp/net/tramp-archive-resources') diff --git a/test/lisp/net/tramp-archive-resources/bar/bar b/test/lisp/net/tramp-archive-resources/bar/bar new file mode 100644 index 00000000000..5716ca5987c --- /dev/null +++ b/test/lisp/net/tramp-archive-resources/bar/bar @@ -0,0 +1 @@ +bar diff --git a/test/lisp/net/tramp-archive-resources/foo.hrd b/test/lisp/net/tramp-archive-resources/foo.hrd new file mode 100644 index 00000000000..257cc5642cb --- /dev/null +++ b/test/lisp/net/tramp-archive-resources/foo.hrd @@ -0,0 +1 @@ +foo diff --git a/test/lisp/net/tramp-archive-resources/foo.lnk b/test/lisp/net/tramp-archive-resources/foo.lnk new file mode 120000 index 00000000000..996f1789ff6 --- /dev/null +++ b/test/lisp/net/tramp-archive-resources/foo.lnk @@ -0,0 +1 @@ +foo.txt \ No newline at end of file diff --git a/test/lisp/net/tramp-archive-resources/foo.tar.gz b/test/lisp/net/tramp-archive-resources/foo.tar.gz new file mode 100644 index 00000000000..68925b147fc Binary files /dev/null and b/test/lisp/net/tramp-archive-resources/foo.tar.gz differ diff --git a/test/lisp/net/tramp-archive-resources/foo.txt b/test/lisp/net/tramp-archive-resources/foo.txt new file mode 100644 index 00000000000..257cc5642cb --- /dev/null +++ b/test/lisp/net/tramp-archive-resources/foo.txt @@ -0,0 +1 @@ +foo -- cgit v1.2.3 From d263ce25cd3a751b510abcc8bc67b0ee1ffa96d5 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Mon, 1 Jan 2018 01:15:39 -0800 Subject: Update copyright year to 2018 Run admin/update-copyright. --- etc/NEWS | 2 +- lib/fsusage.c | 4 ++-- lib/fsusage.h | 2 +- lisp/emacs-lisp/faceup.el | 2 +- lisp/net/tramp-archive.el | 2 +- m4/fsusage.m4 | 3 ++- src/json.c | 2 +- src/ptr-bounds.h | 2 +- test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el | 2 +- .../emacs-lisp/faceup-resources/faceup-test-this-file-directory.el | 2 +- test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el | 2 +- test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el | 2 +- test/lisp/net/tramp-archive-resources/foo.lnk | 2 +- test/lisp/net/tramp-archive-tests.el | 2 +- test/src/json-tests.el | 2 +- test/src/keyboard-tests.el | 2 +- 16 files changed, 18 insertions(+), 17 deletions(-) mode change 120000 => 100644 test/lisp/net/tramp-archive-resources/foo.lnk (limited to 'test/lisp/net/tramp-archive-resources') diff --git a/etc/NEWS b/etc/NEWS index 64c74c0d56e..dd907ab76fb 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1,6 +1,6 @@ GNU Emacs NEWS -- history of user-visible changes. -Copyright (C) 2017 Free Software Foundation, Inc. +Copyright (C) 2017-2018 Free Software Foundation, Inc. See the end of the file for license conditions. Please send Emacs bug reports to bug-gnu-emacs@gnu.org. diff --git a/lib/fsusage.c b/lib/fsusage.c index b670c0c43a1..3482c5f3ac3 100644 --- a/lib/fsusage.c +++ b/lib/fsusage.c @@ -1,7 +1,7 @@ /* fsusage.c -- return space usage of mounted file systems - Copyright (C) 1991-1992, 1996, 1998-1999, 2002-2006, 2009-2017 Free Software - Foundation, Inc. + Copyright (C) 1991-1992, 1996, 1998-1999, 2002-2006, 2009-2018 Free + Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/fsusage.h b/lib/fsusage.h index f78edc6a0cb..65daa736765 100644 --- a/lib/fsusage.h +++ b/lib/fsusage.h @@ -1,6 +1,6 @@ /* fsusage.h -- declarations for file system space usage info - Copyright (C) 1991-1992, 1997, 2003-2006, 2009-2017 Free Software + Copyright (C) 1991-1992, 1997, 2003-2006, 2009-2018 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lisp/emacs-lisp/faceup.el b/lisp/emacs-lisp/faceup.el index 8d2818fbab8..bbf4c5da7e5 100644 --- a/lisp/emacs-lisp/faceup.el +++ b/lisp/emacs-lisp/faceup.el @@ -1,6 +1,6 @@ ;;; faceup.el --- Markup language for faces and font-lock regression testing -*- lexical-binding: t -*- -;; Copyright (C) 2013-2017 Free Software Foundation, Inc. +;; Copyright (C) 2013-2018 Free Software Foundation, Inc. ;; Author: Anders Lindgren ;; Version: 0.0.6 diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index d3b2712fb39..6c96075a001 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -1,6 +1,6 @@ ;;; tramp-archive.el --- Tramp archive manager -*- lexical-binding:t -*- -;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Copyright (C) 2017-2018 Free Software Foundation, Inc. ;; Author: Michael Albinus ;; Keywords: comm, processes diff --git a/m4/fsusage.m4 b/m4/fsusage.m4 index 1d6ad41cd3c..f5faacf055a 100644 --- a/m4/fsusage.m4 +++ b/m4/fsusage.m4 @@ -1,7 +1,8 @@ # serial 32 # Obtaining file system usage information. -# Copyright (C) 1997-1998, 2000-2001, 2003-2017 Free Software Foundation, Inc. +# Copyright (C) 1997-1998, 2000-2001, 2003-2018 Free Software +# Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/src/json.c b/src/json.c index 93dcc730dae..12ba7afa6a0 100644 --- a/src/json.c +++ b/src/json.c @@ -1,6 +1,6 @@ /* JSON parsing and serialization. -Copyright (C) 2017 Free Software Foundation, Inc. +Copyright (C) 2017-2018 Free Software Foundation, Inc. This file is part of GNU Emacs. diff --git a/src/ptr-bounds.h b/src/ptr-bounds.h index 76740da3d33..8cbd58d72b0 100644 --- a/src/ptr-bounds.h +++ b/src/ptr-bounds.h @@ -1,6 +1,6 @@ /* Pointer bounds checking for GNU Emacs -Copyright 2017 Free Software Foundation, Inc. +Copyright 2017-2018 Free Software Foundation, Inc. This file is part of GNU Emacs. diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el index ec2cf272368..7d1a128694c 100644 --- a/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el @@ -1,6 +1,6 @@ ;;; faceup-test-mode.el --- Dummy major mode for testing `faceup'. -;; Copyright (C) 2014-2017 Free Software Foundation, Inc. +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. ;; Author: Anders Lindgren ;; Keywords: languages, faces diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el index e9d8b7074c2..0558bd12e5f 100644 --- a/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el @@ -1,6 +1,6 @@ ;;; faceup-test-this-file-directory.el --- Support file for faceup tests -;; Copyright (C) 2014-2017 Free Software Foundation, Inc. +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. ;; Author: Anders Lindgren ;; Keywords: languages, faces diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el index fd58c1bbca6..f910a1d732a 100644 --- a/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el @@ -1,6 +1,6 @@ ;;; faceup-test-basics.el --- Tests for the `faceup' package. -;; Copyright (C) 2014-2017 Free Software Foundation, Inc. +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. ;; Author: Anders Lindgren ;; Keywords: languages, faces diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el index 0f136862094..8df38bcc8a9 100644 --- a/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el @@ -1,6 +1,6 @@ ;;; faceup-test-files.el --- Self test of `faceup' using dummy major mode. -;; Copyright (C) 2014-2017 Free Software Foundation, Inc. +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. ;; Author: Anders Lindgren ;; Keywords: languages, faces diff --git a/test/lisp/net/tramp-archive-resources/foo.lnk b/test/lisp/net/tramp-archive-resources/foo.lnk deleted file mode 120000 index 996f1789ff6..00000000000 --- a/test/lisp/net/tramp-archive-resources/foo.lnk +++ /dev/null @@ -1 +0,0 @@ -foo.txt \ No newline at end of file diff --git a/test/lisp/net/tramp-archive-resources/foo.lnk b/test/lisp/net/tramp-archive-resources/foo.lnk new file mode 100644 index 00000000000..257cc5642cb --- /dev/null +++ b/test/lisp/net/tramp-archive-resources/foo.lnk @@ -0,0 +1 @@ +foo diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 464eb6c8b82..85be2dc6230 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -1,6 +1,6 @@ ;;; tramp-archive-tests.el --- Tests of file archive access -*- lexical-binding:t -*- -;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Copyright (C) 2017-2018 Free Software Foundation, Inc. ;; Author: Michael Albinus diff --git a/test/src/json-tests.el b/test/src/json-tests.el index 107cab89083..47bccbe6f3e 100644 --- a/test/src/json-tests.el +++ b/test/src/json-tests.el @@ -1,6 +1,6 @@ ;;; json-tests.el --- unit tests for json.c -*- lexical-binding: t; -*- -;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Copyright (C) 2017-2018 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. diff --git a/test/src/keyboard-tests.el b/test/src/keyboard-tests.el index 301cef0092c..125dbd09391 100644 --- a/test/src/keyboard-tests.el +++ b/test/src/keyboard-tests.el @@ -1,6 +1,6 @@ ;;; keyboard-tests.el --- Tests for keyboard.c -*- lexical-binding: t -*- -;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Copyright (C) 2017-2018 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. -- cgit v1.2.3 From cef8a9d0a7104626b0c238d6298e1d47c196306c Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Tue, 2 Jan 2018 11:25:21 +0100 Subject: Remove superfluous test data for Tramp --- test/lisp/net/tramp-archive-resources/bar/bar | 1 - test/lisp/net/tramp-archive-resources/foo.hrd | 1 - test/lisp/net/tramp-archive-resources/foo.lnk | 1 - test/lisp/net/tramp-archive-resources/foo.txt | 1 - 4 files changed, 4 deletions(-) delete mode 100644 test/lisp/net/tramp-archive-resources/bar/bar delete mode 100644 test/lisp/net/tramp-archive-resources/foo.hrd delete mode 100644 test/lisp/net/tramp-archive-resources/foo.lnk delete mode 100644 test/lisp/net/tramp-archive-resources/foo.txt (limited to 'test/lisp/net/tramp-archive-resources') diff --git a/test/lisp/net/tramp-archive-resources/bar/bar b/test/lisp/net/tramp-archive-resources/bar/bar deleted file mode 100644 index 5716ca5987c..00000000000 --- a/test/lisp/net/tramp-archive-resources/bar/bar +++ /dev/null @@ -1 +0,0 @@ -bar diff --git a/test/lisp/net/tramp-archive-resources/foo.hrd b/test/lisp/net/tramp-archive-resources/foo.hrd deleted file mode 100644 index 257cc5642cb..00000000000 --- a/test/lisp/net/tramp-archive-resources/foo.hrd +++ /dev/null @@ -1 +0,0 @@ -foo diff --git a/test/lisp/net/tramp-archive-resources/foo.lnk b/test/lisp/net/tramp-archive-resources/foo.lnk deleted file mode 100644 index 257cc5642cb..00000000000 --- a/test/lisp/net/tramp-archive-resources/foo.lnk +++ /dev/null @@ -1 +0,0 @@ -foo diff --git a/test/lisp/net/tramp-archive-resources/foo.txt b/test/lisp/net/tramp-archive-resources/foo.txt deleted file mode 100644 index 257cc5642cb..00000000000 --- a/test/lisp/net/tramp-archive-resources/foo.txt +++ /dev/null @@ -1 +0,0 @@ -foo -- cgit v1.2.3 From fd6972ac0720bde830728254b8d791c81e01d63f Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Tue, 30 Jan 2018 17:34:02 +0100 Subject: Fix Bug#30262 * lisp/net/tramp-archive.el (tramp-archive-hash): Document (changed) layout. (tramp-archive-dissect-file-name): Merge with `tramp-archive-local-copy', which has been removed by this. (tramp-archive-cleanup-hash): Adapt to changed `tramp-archive-hash'. (Bug#30262) * lisp/net/tramp-gvfs.el (tramp-gvfs-unmount): Flush connection properties. * test/lisp/net/tramp-archive-tests.el (tramp-archive-test01-file-name-syntax) (tramp-archive-test02-file-name-dissect) (tramp-archive-test16-directory-files) (tramp-archive-test26-file-name-completion): Adapt to changed test file. (tramp-archive-test08-file-local-copy): Be more robust in cleanup. * test/lisp/net/tramp-archive-resources/foo.tar.gz: Adapt to extended test. --- lisp/net/tramp-archive.el | 111 ++++++++++++----------- lisp/net/tramp-gvfs.el | 17 ++-- test/lisp/net/tramp-archive-resources/foo.tar.gz | Bin 234 -> 274 bytes test/lisp/net/tramp-archive-tests.el | 32 ++++--- 4 files changed, 84 insertions(+), 76 deletions(-) (limited to 'test/lisp/net/tramp-archive-resources') diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 45e3bf0a606..ac8b76b9442 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -301,27 +301,42 @@ pass to the OPERATION." t)) (defvar tramp-archive-hash (make-hash-table :test 'equal) - "Hash table for archive local copies.") - -(defun tramp-archive-local-copy (archive) - "Return copy of ARCHIVE, usable by GVFS. -ARCHIVE is the archive component of an archive file name." - (setq archive (file-truename archive)) - (let ((tramp-verbose 0)) - (with-tramp-connection-property - ;; This is just an auxiliary VEC for caching properties. - (make-tramp-file-name :method tramp-archive-method :host archive) - "archive" + "Hash table for archive local copies. +The hash key is the archive name. The value is a cons of the +used `tramp-file-name' structure for tramp-gvfs, and the file +name of a local copy, if any.") + +(defun tramp-archive-dissect-file-name (name) + "Return a `tramp-file-name' structure. +The structure consists of the `tramp-archive-method' method, the +hexlified archive name as host, and the localname. The archive +name is kept in slot `hop'" + (save-match-data + (unless (tramp-archive-file-name-p name) + (tramp-compat-user-error nil "Not an archive file name: \"%s\"" name)) + ;; The `string-match' happened in `tramp-archive-file-name-p'. + (let ((archive (match-string 1 name)) + (localname (match-string 2 name)) + (tramp-verbose 0) + vec copy) + + (setq archive (file-truename archive)) + (cond + ;; The value is already in the hash table. + ((setq vec (car (gethash archive tramp-archive-hash)))) + ;; File archives inside file archives. ((tramp-archive-file-name-p archive) (let ((archive (tramp-make-tramp-file-name (tramp-archive-dissect-file-name archive) nil 'noarchive))) - ;; We call `file-attributes' in order to mount the archive. - (file-attributes archive) - (puthash archive nil tramp-archive-hash) - archive)) + (setq vec + (make-tramp-file-name + :method tramp-archive-method :hop archive + :host (url-hexify-string (tramp-gvfs-url-file-name archive))))) + (puthash archive (list vec) tramp-archive-hash)) + ;; http://... ((and url-handler-mode tramp-compat-use-url-tramp-p @@ -332,26 +347,36 @@ ARCHIVE is the archive component of an archive file name." (url-type (url-generic-parse-url archive)) url-tramp-protocols)) (archive (url-tramp-convert-url-to-tramp archive))) - (puthash archive nil tramp-archive-hash) - archive)) + (setq vec + (make-tramp-file-name + :method tramp-archive-method :hop archive + :host (url-hexify-string (tramp-gvfs-url-file-name archive))))) + (puthash archive (list vec) tramp-archive-hash)) + ;; GVFS supported schemes. ((or (tramp-gvfs-file-name-p archive) (not (file-remote-p archive))) - (puthash archive nil tramp-archive-hash) - archive) + (setq vec + (make-tramp-file-name + :method tramp-archive-method :hop archive + :host (url-hexify-string (tramp-gvfs-url-file-name archive)))) + (puthash archive (list vec) tramp-archive-hash)) + ;; Anything else. Here we call `file-local-copy', which we ;; have avoided so far. (t (let ((inhibit-file-name-operation 'file-local-copy) (inhibit-file-name-handlers - (cons 'jka-compr-handler inhibit-file-name-handlers)) - result) - (or (and (setq result (gethash archive tramp-archive-hash nil)) - (file-readable-p result)) - (puthash - archive - (setq result (file-local-copy archive)) - tramp-archive-hash)) - result)))))) + (cons 'jka-compr-handler inhibit-file-name-handlers))) + (setq copy (file-local-copy archive) + vec + (make-tramp-file-name + :method tramp-archive-method :hop archive + :host (url-hexify-string (tramp-gvfs-url-file-name copy))))) + (puthash archive (cons vec copy) tramp-archive-hash))) + + ;; So far, `vec' handles just the mount point. Add `localname'. + (setf (tramp-file-name-localname vec) localname) + vec))) ;;;###tramp-autoload (defun tramp-archive-cleanup-hash () @@ -360,16 +385,10 @@ ARCHIVE is the archive component of an archive file name." (lambda (key value) ;; Unmount local copy. (ignore-errors - (let ((tramp-gvfs-methods tramp-archive-all-gvfs-methods) - (file-archive (file-name-as-directory key))) - (tramp-message - (and (tramp-tramp-file-p key) (tramp-dissect-file-name key)) 3 - "Unmounting %s" file-archive) - (tramp-gvfs-unmount - (tramp-dissect-file-name - (tramp-archive-gvfs-file-name file-archive))))) + (tramp-message (car value) 3 "Unmounting %s" (or (cdr value) key)) + (tramp-gvfs-unmount (car value))) ;; Delete local copy. - (ignore-errors (when value (delete-file value))) + (ignore-errors (delete-file (cdr value))) (remhash key tramp-archive-hash)) tramp-archive-hash) (clrhash tramp-archive-hash)) @@ -380,24 +399,6 @@ ARCHIVE is the archive component of an archive file name." (remove-hook 'kill-emacs-hook 'tramp-archive-cleanup-hash))) -(defun tramp-archive-dissect-file-name (name) - "Return a `tramp-file-name' structure. -The structure consists of the `tramp-archive-method' method, the -hexlified archive name as host, and the localname. The archive -name is kept in slot `hop'" - (save-match-data - (unless (tramp-archive-file-name-p name) - (tramp-compat-user-error nil "Not an archive file name: \"%s\"" name)) - ;; The `string-match' happened in `tramp-archive-file-name-p'. - (let ((archive (match-string 1 name)) - (localname (match-string 2 name)) - (tramp-verbose 0)) - (make-tramp-file-name - :method tramp-archive-method :user nil :domain nil :host - (url-hexify-string - (tramp-gvfs-url-file-name (tramp-archive-local-copy archive))) - :port nil :localname localname :hop archive)))) - (defsubst tramp-file-name-archive (vec) "Extract the archive file name from VEC. VEC is expected to be a `tramp-file-name', with the method being diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 6745ae02c7b..70ac077a7c5 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -1778,13 +1778,16 @@ file-notify events." (defun tramp-gvfs-unmount (vec) "Unmount the object identified by VEC." - (let ((vec (copy-tramp-file-name vec))) - (setf (tramp-file-name-localname vec) "/" - (tramp-file-name-hop vec) nil) - (when (tramp-gvfs-connection-mounted-p vec) - (tramp-gvfs-send-command - vec "gvfs-mount" "-u" - (tramp-gvfs-url-file-name (tramp-make-tramp-file-name vec)))))) + (setf (tramp-file-name-localname vec) "/" + (tramp-file-name-hop vec) nil) + (when (tramp-gvfs-connection-mounted-p vec) + (tramp-gvfs-send-command + vec "gvfs-mount" "-u" + (tramp-gvfs-url-file-name (tramp-make-tramp-file-name vec)))) + (while (tramp-gvfs-connection-mounted-p vec) + (read-event nil nil 0.1)) + (tramp-flush-connection-properties vec) + (tramp-flush-connection-properties (tramp-get-connection-process vec))) (defun tramp-gvfs-mount-spec-entry (key value) "Construct a mount-spec entry to be used in a mount_spec. diff --git a/test/lisp/net/tramp-archive-resources/foo.tar.gz b/test/lisp/net/tramp-archive-resources/foo.tar.gz index 68925b147fc..0d2e9878dd7 100644 Binary files a/test/lisp/net/tramp-archive-resources/foo.tar.gz and b/test/lisp/net/tramp-archive-resources/foo.tar.gz differ diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 149ed370432..82dd5de8b9a 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -99,9 +99,9 @@ variables, so we check the Emacs version directly." (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo/bar"))) ;; A file archive inside a file archive. (should - (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo.tar"))) + (tramp-archive-file-name-p (concat tramp-archive-test-archive "baz.tar"))) (should - (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo.tar/")))) + (tramp-archive-file-name-p (concat tramp-archive-test-archive "baz.tar/")))) (ert-deftest tramp-archive-test02-file-name-dissect () "Check archive file name components." @@ -145,13 +145,14 @@ variables, so we check the Emacs version directly." ;; File archive in file archive. (let* ((tramp-archive-test-file-archive - (concat tramp-archive-test-archive "bar.tar")) + (concat tramp-archive-test-archive "baz.tar")) (tramp-archive-test-archive (file-name-as-directory tramp-archive-test-file-archive)) (tramp-methods (cons `(,tramp-archive-method) tramp-methods)) (tramp-gvfs-methods tramp-archive-all-gvfs-methods)) (unwind-protect - (with-parsed-tramp-archive-file-name tramp-archive-test-archive nil + (with-parsed-tramp-archive-file-name + (expand-file-name "bar" tramp-archive-test-archive) nil (should (string-equal method tramp-archive-method)) (should-not user) (should-not domain) @@ -184,8 +185,12 @@ variables, so we check the Emacs version directly." nil "/")) (file-name-nondirectory tramp-archive-test-file-archive))))) (should-not port) - (should (string-equal localname "/")) - (should (string-equal archive tramp-archive-test-file-archive))) + (should (string-equal localname "/bar")) + ;; The `archive' component is now already a Tramp file name. + (should + (string-equal + archive + (tramp-archive-gvfs-file-name tramp-archive-test-file-archive)))) ;; Cleanup. (tramp-archive-cleanup-hash)))) @@ -290,9 +295,8 @@ This checks also `file-name-as-directory', `file-name-directory', :type tramp-file-missing)) ;; Cleanup. - (ignore-errors - (tramp-archive--test-delete tmp-name) - (tramp-archive-cleanup-hash))))) + (ignore-errors (tramp-archive--test-delete tmp-name)) + (tramp-archive-cleanup-hash)))) (ert-deftest tramp-archive-test09-insert-file-contents () "Check `insert-file-contents'." @@ -444,7 +448,7 @@ This checks also `file-name-as-directory', `file-name-directory', (skip-unless tramp-gvfs-enabled) (let ((tmp-name tramp-archive-test-archive) - (files '("." ".." "bar" "foo.hrd" "foo.lnk" "foo.txt"))) + (files '("." ".." "bar" "baz.tar" "foo.hrd" "foo.lnk" "foo.txt"))) (unwind-protect (progn (should (file-directory-p tmp-name)) @@ -656,7 +660,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." ;; Local files. (should (equal (file-name-completion "fo" tmp-name) "foo.")) (should (equal (file-name-completion "foo.txt" tmp-name) t)) - (should (equal (file-name-completion "b" tmp-name) "bar/")) + (should (equal (file-name-completion "b" tmp-name) "ba")) (should-not (file-name-completion "a" tmp-name)) (should (equal @@ -668,18 +672,18 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (should (equal (sort (file-name-all-completions "b" tmp-name) 'string-lessp) - '("bar/"))) + '("bar/" "baz.tar"))) (should-not (file-name-all-completions "a" tmp-name)) ;; `completion-regexp-list' restricts the completion to ;; files which match all expressions in this list. (let ((completion-regexp-list `(,directory-files-no-dot-files-regexp "b"))) (should - (equal (file-name-completion "" tmp-name) "bar/")) + (equal (file-name-completion "" tmp-name) "ba")) (should (equal (sort (file-name-all-completions "" tmp-name) 'string-lessp) - '("bar/"))))) + '("bar/" "baz.tar"))))) ;; Cleanup. (tramp-archive-cleanup-hash)))) -- cgit v1.2.3 From 84d066a73fc4191a675c87c81ec1a4f531375e95 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Wed, 31 Jan 2018 15:02:46 +0100 Subject: Fix Bug#30293 * lisp/net/tramp-archive.el (tramp-archive-file-name-for-operation): New defsubst. (tramp-archive-file-name-archive, tramp-archive-file-name-localname): New defuns. (tramp-archive-file-name-handler, tramp-archive-dissect-file-name) (tramp-archive-handle-not-implemented): Use them. (Bug#30293) * test/lisp/net/tramp-archive-tests.el (tramp-archive-test-directory): New defconst. (tramp-archive-test01-file-name-syntax): Extend test. (tramp-archive-test05-expand-file-name-non-archive-directory): New test. (Bug#30293) * test/lisp/net/tramp-archive-resources/foo.iso/foo: New file. --- lisp/net/tramp-archive.el | 49 +++++++++++++------ test/lisp/net/tramp-archive-resources/foo.iso/foo | 1 + test/lisp/net/tramp-archive-tests.el | 59 ++++++++++++++++++++++- 3 files changed, 94 insertions(+), 15 deletions(-) create mode 100644 test/lisp/net/tramp-archive-resources/foo.iso/foo (limited to 'test/lisp/net/tramp-archive-resources') diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 51ee18fac7a..8d292e16023 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -253,21 +253,33 @@ It must be supported by libarchive(3).") "Alist of handler functions for GVFS archive method. Operations not mentioned here will be handled by the default Emacs primitives.") +(defsubst tramp-archive-file-name-for-operation (operation &rest args) + "Like `tramp-file-name-for-operation', but for archive file name syntax." + (cl-letf (((symbol-function 'tramp-tramp-file-p) 'tramp-archive-file-name-p)) + (apply 'tramp-file-name-for-operation operation args))) + ;;;###tramp-autoload (defun tramp-archive-file-name-handler (operation &rest args) "Invoke the GVFS archive related OPERATION. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (unless tramp-gvfs-enabled - (tramp-compat-user-error nil "Package `tramp-archive' not supported")) - (let ((tramp-methods (cons `(,tramp-archive-method) tramp-methods)) - (tramp-gvfs-methods tramp-archive-all-gvfs-methods) - (fn (assoc operation tramp-archive-file-name-handler-alist))) - (when (eq (cdr fn) 'tramp-archive-handle-not-implemented) - (setq args (cons operation args))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (let* ((filename (apply 'tramp-archive-file-name-for-operation + operation args)) + (archive (tramp-archive-file-name-archive filename))) + ;; The file archive could be a directory, see Bug#30293. + (if (file-directory-p archive) + (tramp-run-real-handler operation args) + ;; Now run the handler. + (unless tramp-gvfs-enabled + (tramp-compat-user-error nil "Package `tramp-archive' not supported")) + (let ((tramp-methods (cons `(,tramp-archive-method) tramp-methods)) + (tramp-gvfs-methods tramp-archive-all-gvfs-methods) + (fn (assoc operation tramp-archive-file-name-handler-alist))) + (when (eq (cdr fn) 'tramp-archive-handle-not-implemented) + (setq args (cons operation args))) + (if fn + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args)))))) ;; Mark `operations' the handler is responsible for. (put 'tramp-archive-file-name-handler 'operations @@ -300,6 +312,16 @@ pass to the OPERATION." (string-match tramp-archive-file-name-regexp name) t)) +(defun tramp-archive-file-name-archive (name) + "Return archive part of NAME." + (and (tramp-archive-file-name-p name) + (match-string 1 name))) + +(defun tramp-archive-file-name-localname (name) + "Return localname part of NAME." + (and (tramp-archive-file-name-p name) + (match-string 2 name))) + (defvar tramp-archive-hash (make-hash-table :test 'equal) "Hash table for archive local copies. The hash key is the archive name. The value is a cons of the @@ -314,9 +336,8 @@ name is kept in slot `hop'" (save-match-data (unless (tramp-archive-file-name-p name) (tramp-compat-user-error nil "Not an archive file name: \"%s\"" name)) - ;; The `string-match' happened in `tramp-archive-file-name-p'. - (let* ((localname (match-string 2 name)) - (archive (file-truename (match-string 1 name))) + (let* ((localname (tramp-archive-file-name-localname name)) + (archive (file-truename (tramp-archive-file-name-archive name))) (vec (make-tramp-file-name :method tramp-archive-method :hop archive))) @@ -535,7 +556,7 @@ offered." "Generic handler for operations not implemented for file archives." (let ((v (ignore-errors (tramp-archive-dissect-file-name - (apply 'tramp-file-name-for-operation operation args))))) + (apply 'tramp-archive-file-name-for-operation operation args))))) (tramp-message v 10 "%s" (cons operation args)) (tramp-error v 'file-error diff --git a/test/lisp/net/tramp-archive-resources/foo.iso/foo b/test/lisp/net/tramp-archive-resources/foo.iso/foo new file mode 100644 index 00000000000..257cc5642cb --- /dev/null +++ b/test/lisp/net/tramp-archive-resources/foo.iso/foo @@ -0,0 +1 @@ +foo diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index ecfee0c556c..96c6a71097c 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -46,6 +46,11 @@ (file-name-as-directory tramp-archive-test-file-archive) "The test archive.") +(defconst tramp-archive-test-directory + (file-truename + (expand-file-name "foo.iso" tramp-archive-test-resource-directory)) + "A directory file name, which looks like an archive.") + (setq password-cache-expiry nil tramp-verbose 0 tramp-cache-read-persistent-data t ;; For auth-sources. @@ -94,14 +99,51 @@ variables, so we check the Emacs version directly." "Check archive file name syntax." (should-not (tramp-archive-file-name-p tramp-archive-test-file-archive)) (should (tramp-archive-file-name-p tramp-archive-test-archive)) + (should + (string-equal + (tramp-archive-file-name-archive tramp-archive-test-archive) + tramp-archive-test-file-archive)) + (should + (string-equal + (tramp-archive-file-name-localname tramp-archive-test-archive) "/")) (should (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo"))) + (should + (string-equal + (tramp-archive-file-name-localname + (concat tramp-archive-test-archive "foo")) + "/foo")) (should (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo/bar"))) + (should + (string-equal + (tramp-archive-file-name-localname + (concat tramp-archive-test-archive "foo/bar")) + "/foo/bar")) ;; A file archive inside a file archive. (should (tramp-archive-file-name-p (concat tramp-archive-test-archive "baz.tar"))) (should - (tramp-archive-file-name-p (concat tramp-archive-test-archive "baz.tar/")))) + (string-equal + (tramp-archive-file-name-archive + (concat tramp-archive-test-archive "baz.tar")) + tramp-archive-test-file-archive)) + (should + (string-equal + (tramp-archive-file-name-localname + (concat tramp-archive-test-archive "baz.tar")) + "/baz.tar")) + (should + (tramp-archive-file-name-p (concat tramp-archive-test-archive "baz.tar/"))) + (should + (string-equal + (tramp-archive-file-name-archive + (concat tramp-archive-test-archive "baz.tar/")) + (concat tramp-archive-test-archive "baz.tar"))) + (should + (string-equal + (tramp-archive-file-name-localname + (concat tramp-archive-test-archive "baz.tar/")) + "/"))) (ert-deftest tramp-archive-test02-file-name-dissect () "Check archive file name components." @@ -205,6 +247,21 @@ variables, so we check the Emacs version directly." (should (string-equal (expand-file-name "/foo.tar/./file") "/foo.tar/file")) (should (string-equal (expand-file-name "/foo.tar/../file") "/file"))) +;; This test is inspired by Bug#30293. +(ert-deftest tramp-archive-test05-expand-file-name-non-archive-directory () + "Check existing directories with archive file name syntax. +They shall still be supported" + (should (file-directory-p tramp-archive-test-directory)) + ;; `tramp-archive-file-name-p' tests only for file name syntax. It + ;; doesn't test, whether it is really a file archive. + (should + (tramp-archive-file-name-p + (file-name-as-directory tramp-archive-test-directory))) + (should + (file-directory-p (file-name-as-directory tramp-archive-test-directory))) + (should + (file-exists-p (expand-file-name "foo" tramp-archive-test-directory)))) + (ert-deftest tramp-archive-test06-directory-file-name () "Check `directory-file-name'. This checks also `file-name-as-directory', `file-name-directory', -- cgit v1.2.3