commit 94179453039a23b7f2aefa990e317f72a3df03d5 (HEAD, refs/remotes/origin/master) Author: Glenn Morris Date: Sat Dec 9 19:17:18 2017 -0800 * test/lisp/net/tramp-archive-tests.el (tramp-archive-test06-directory-file-name): Add skip condition. diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index bbe7d4c9aa..2c9f56e47c 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -205,6 +205,7 @@ variables, so we check the Emacs version directly." "Check `directory-file-name'. This checks also `file-name-as-directory', `file-name-directory', `file-name-nondirectory' and `unhandled-file-name-directory'." + (skip-unless tramp-gvfs-enabled) (should (string-equal (directory-file-name "/foo.tar/path/to/file") "/foo.tar/path/to/file")) commit ac6ea598302cd33014880a7a5f43d42a7e5d1f01 Author: Philipp Stephani Date: Sat Dec 9 22:03:31 2017 +0100 * lisp/emacs-lisp/advice.el: Stop using old-style backquotes diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 8286766775..d5da30fb18 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1514,7 +1514,7 @@ ;; `ad-return-value' in a piece of after advice. For example: ;; ;; (defmacro foom (x) -;; (` (list (, x)))) +;; `(list ,x)) ;; foom ;; ;; (foom '(a)) @@ -1547,8 +1547,8 @@ ;; (defadvice foom (after fg-print-x act) ;; "Print the value of X." ;; (setq ad-return-value -;; (` (progn (print (, x)) -;; (, ad-return-value))))) +;; `(progn (print ,x) +;; ,ad-return-value))) ;; foom ;; ;; (macroexpand '(foom '(a))) commit 8b8197235f058276823832eadce66e2de2f9a9cf Author: Philipp Stephani Date: Tue Oct 3 16:14:54 2017 +0200 Raise an error when detecting old-style backquotes. They have been deprecated for a decade now. * src/lread.c (Fload): Don't use record_unwind_protect to warn about old-style backquotes any more. They now generate a hard error. (read1): Signal an error when detecting old-style backquotes. Remove unused label. (syms_of_lread): Remove unused internal variable 'lread--old-style-backquotes'. (load_error_old_style_backquotes): Rename from 'load_warn_oldstyle_backquotes'. Signal an error. * lisp/emacs-lisp/bytecomp.el (byte-compile-from-buffer): Remove check from byte compiler. It isn't triggered any more. * test/src/lread-tests.el (lread-tests--old-style-backquotes): Adapt unit test. * test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-tests--old-style-backquotes) (bytecomp-tests-function-put): Adapt unit tests. * etc/NEWS: Document change. diff --git a/etc/NEWS b/etc/NEWS index b8103c6b29..dd7d983970 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -144,6 +144,9 @@ them through 'format' first. Even that is discouraged: for ElDoc support, you should set 'eldoc-documentation-function' instead of calling 'eldoc-message' directly. +** Old-style backquotes now generate an error. They have been +generating warnings for a decade. + * Lisp Changes in Emacs 27.1 diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index f69ac7f342..995fb05eac 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2063,14 +2063,8 @@ With argument ARG, insert value in current buffer after the form." (not (eobp))) (setq byte-compile-read-position (point) byte-compile-last-position byte-compile-read-position) - (let* ((lread--old-style-backquotes nil) - (lread--unescaped-character-literals nil) + (let* ((lread--unescaped-character-literals nil) (form (read inbuffer))) - ;; Warn about the use of old-style backquotes. - (when lread--old-style-backquotes - (byte-compile-warn "!! The file uses old-style backquotes !! -This functionality has been obsolete for more than 10 years already -and will be removed soon. See (elisp)Backquote in the manual.")) (when lread--unescaped-character-literals (byte-compile-warn "unescaped character literals %s detected!" diff --git a/src/lread.c b/src/lread.c index a808087603..52897b4fcc 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1003,14 +1003,11 @@ load_error_handler (Lisp_Object data) return Qnil; } -static void -load_warn_old_style_backquotes (Lisp_Object file) +static _Noreturn void +load_error_old_style_backquotes (void) { - if (!NILP (Vlread_old_style_backquotes)) - { - AUTO_STRING (format, "Loading `%s': old-style backquotes detected!"); - CALLN (Fmessage, format, file); - } + AUTO_STRING (format, "Loading `%s': old-style backquotes detected!"); + xsignal1 (Qerror, CALLN (Fformat_message, format, Vload_file_name)); } static void @@ -1282,10 +1279,6 @@ Return t if the file exists and loads successfully. */) version = -1; - /* Check for the presence of old-style quotes and warn about them. */ - specbind (Qlread_old_style_backquotes, Qnil); - record_unwind_protect (load_warn_old_style_backquotes, file); - /* Check for the presence of unescaped character literals and warn about them. */ specbind (Qlread_unescaped_character_literals, Qnil); @@ -3178,10 +3171,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) first_in_list exception (old-style can still be obtained via "(\`" anyway). */ if (!new_backquote_flag && first_in_list && next_char == ' ') - { - Vlread_old_style_backquotes = Qt; - goto default_label; - } + load_error_old_style_backquotes (); else { Lisp_Object value; @@ -3232,10 +3222,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) return list2 (comma_type, value); } else - { - Vlread_old_style_backquotes = Qt; - goto default_label; - } + load_error_old_style_backquotes (); } case '?': { @@ -3423,7 +3410,6 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) row. */ FALLTHROUGH; default: - default_label: if (c <= 040) goto retry; if (c == NO_BREAK_SPACE) goto retry; @@ -4996,12 +4982,6 @@ variables, this must be set in the first line of a file. */); doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */); Veval_buffer_list = Qnil; - DEFVAR_LISP ("lread--old-style-backquotes", Vlread_old_style_backquotes, - doc: /* Set to non-nil when `read' encounters an old-style backquote. -For internal use only. */); - Vlread_old_style_backquotes = Qnil; - DEFSYM (Qlread_old_style_backquotes, "lread--old-style-backquotes"); - DEFVAR_LISP ("lread--unescaped-character-literals", Vlread_unescaped_character_literals, doc: /* List of deprecated unescaped character literals encountered by `read'. diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index f508c36542..734c4a386a 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -534,23 +534,18 @@ literals (Bug#20852)." (ert-deftest bytecomp-tests--old-style-backquotes () "Check that byte compiling warns about old-style backquotes." - (should (boundp 'lread--old-style-backquotes)) (bytecomp-tests--with-temp-file source (write-region "(` (a b))" nil source) (bytecomp-tests--with-temp-file destination (let* ((byte-compile-dest-file-function (lambda (_) destination)) - (byte-compile-error-on-warn t) - (byte-compile-debug t) - (err (should-error (byte-compile-file source)))) + (byte-compile-debug t) + (err (should-error (byte-compile-file source)))) (should (equal (cdr err) - (list "!! The file uses old-style backquotes !! -This functionality has been obsolete for more than 10 years already -and will be removed soon. See (elisp)Backquote in the manual."))))))) + '("Loading `nil': old-style backquotes detected!"))))))) (ert-deftest bytecomp-tests-function-put () "Check `function-put' operates during compilation." - (should (boundp 'lread--old-style-backquotes)) (bytecomp-tests--with-temp-file source (dolist (form '((function-put 'bytecomp-tests--foo 'foo 1) (function-put 'bytecomp-tests--foo 'bar 2) diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index ac730b4f00..3f41982eba 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -173,13 +173,13 @@ literals (Bug#20852)." (should (string-suffix-p "/somelib.el" (caar load-history))))) (ert-deftest lread-tests--old-style-backquotes () - "Check that loading warns about old-style backquotes." + "Check that loading doesn't accept old-style backquotes." (lread-tests--with-temp-file file-name (write-region "(` (a b))" nil file-name) - (should (equal (load file-name nil :nomessage :nosuffix) t)) - (should (equal (lread-tests--last-message) - (concat (format-message "Loading `%s': " file-name) - "old-style backquotes detected!"))))) + (let ((data (should-error (load file-name nil :nomessage :nosuffix)))) + (should (equal (cdr data) + (list (concat (format-message "Loading `%s': " file-name) + "old-style backquotes detected!"))))))) (ert-deftest lread-lread--substitute-object-in-subtree () (let ((x (cons 0 1))) commit 6fc0397388c9e03a631806667570959a49b49763 Author: Philipp Stephani Date: Sun Oct 15 21:32:17 2017 +0200 Work around reader limitations for old-style backquotes. See Bug#28759. * admin/grammars/make.by: Escape ,@ to avoid old-style backquote detection diff --git a/admin/grammars/make.by b/admin/grammars/make.by index d3a03ead47..4d029186d8 100644 --- a/admin/grammars/make.by +++ b/admin/grammars/make.by @@ -54,15 +54,20 @@ %% +;; Escape the ,@ below because the reader doesn't correctly detect +;; old-style backquotes for this case. The backslashes can be removed +;; once old-style backquotes are completely gone (probably in +;; Emacs 28). + Makefile : bol newline (nil) | bol variable - ( ,@$2 ) + ( \,@$2 ) | bol rule - ( ,@$2 ) + ( \,@$2 ) | bol conditional - ( ,@$2 ) + ( \,@$2 ) | bol include - ( ,@$2 ) + ( \,@$2 ) | whitespace ( nil ) | newline ( nil ) ; @@ -125,13 +130,13 @@ colons: COLON COLON () ; element-list: elements newline - ( ,@$1 ) + ( \,@$1 ) ; elements: element some-whitespace elements - ( ,@$1 ,@$3 ) + ( \,@$1 ,@$3 ) | element - ( ,@$1 ) + ( \,@$1 ) | ;;EMPTY ; commit 0ffd3dbce76c1a967522dbe9ec6f2dffe94ee886 Author: Eli Zaretskii Date: Sat Dec 9 17:36:33 2017 +0200 ; Improve NEWS entry of the last change. diff --git a/etc/NEWS b/etc/NEWS index 0165768bc1..b8103c6b29 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -126,9 +126,9 @@ To restore the old behavior, use * New Modes and Packages in Emacs 27.1 +++ -** The package tramp-archive.el brings file name handler support for -file archives. It works on systems which support GVFS, which is -GNU/Linux, roughly spoken. See the chapter "(tramp) Archive file +** Emacs can now visit files in archives as if they were directories. +This feature uses Tramp and works only on systems which support GVFS, +i.e. GNU/Linux, roughly spoken. See the chapter "(tramp) Archive file names" in the Tramp manual for full documentation of these facilities. commit d338325c2b603db8433c9b6b12216201d5ee21e9 Author: Michael Albinus Date: Sat Dec 9 14:34:30 2017 +0100 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. diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index e7d9cb15de..3869e19fb9 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -164,6 +164,7 @@ Using @value{tramp} * Ad-hoc multi-hops:: Declaring multiple hops in the file name. * Remote processes:: Integration with other Emacs packages. * Cleanup remote connections:: Cleanup remote connections. +* Archive file names:: Access to files in file archives. How file names, directories and localnames are mangled and managed @@ -407,7 +408,8 @@ since April 2007 (and removed in December 2016). GVFS integration started in February 2009. Remote commands on MS Windows hosts since September 2011. Ad-hoc multi-hop methods (with a changed syntax) re-enabled in November 2011. In November 2012, added Juergen -Hoetzel's @file{tramp-adb.el}. +Hoetzel's @file{tramp-adb.el}. Archive file names are supported since +December 2017. XEmacs support was stopped in January 2016. Since March 2017, @value{tramp} syntax mandates a method. @@ -1134,7 +1136,10 @@ requires the SYNCE-GVFS plugin. This user option is a list of external methods for GVFS@. By default, this list includes @option{afp}, @option{dav}, @option{davs}, @option{gdrive}, @option{obex}, @option{sftp} and @option{synce}. -Other methods to include are: @option{ftp} and @option{smb}. +Other methods to include are @option{ftp}, @option{http}, +@option{https} and @option{smb}. These methods are not intended to be +used directly as GVFS based method. Instead, they are added here for +the benefit of @ref{Archive file names}. @end defopt @@ -2284,6 +2289,7 @@ is a feature of Emacs that may cause missed prompts when using * Ad-hoc multi-hops:: Declaring multiple hops in the file name. * Remote processes:: Integration with other Emacs packages. * Cleanup remote connections:: Cleanup remote connections. +* Archive file names:: Access to files in file archives. @end menu @@ -2913,6 +2919,209 @@ that remote connection. @end deffn +@node Archive file names +@section Archive file names +@cindex file archives +@cindex archive file names +@cindex method archive +@cindex archive method + +@value{tramp} offers also transparent access to files inside file +archives. This is possible only on machines which have installed the +virtual file system for the Gnome Desktop (GVFS), @ref{GVFS based +methods}. Internally, file archives are mounted via the GVFS +@option{archive} method. + +A file archive is a regular file of kind @file{/path/to/dir/file.EXT}. +The extension @samp{.EXT} identifies the type of the file archive. A +file inside a file archive, called archive file name, has the name +@file{/path/to/dir/file.EXT/dir/file}. + +Most of the @ref{Magic File Names, , magic file name operations, +elisp}, are implemented for archive file names, exceptions are all +operations which write into a file archive, and process related +operations. Therefore, functions like + +@lisp +(copy-file "/path/to/dir/file.tar/dir/file" "/somewhere/else") +@end lisp + +@noindent +work out of the box. This is also true for file name completion, and +for libraries like @code{dired} or @code{ediff}, which accept archive +file names as well. + +@vindex tramp-archive-suffixes +File archives are identified by the file name extension @samp{.EXT}. +Since GVFS uses internally the library @code{libarchive(3)}, all +suffixes, which are accepted by this library, work also for archive +file names. Accepted suffixes are listed in the constant +@code{tramp-archive-suffixes}. They are + +@itemize +@item @samp{.7z} --- +7-Zip archives +@cindex 7z, file archive suffix +@cindex file archive suffix 7z + +@item @samp{.apk} --- +Android package kits +@cindex apk, file archive suffix +@cindex file archive suffix apk + +@item @samp{.ar} --- +UNIX archiver formats +@cindex ar, file archive suffix +@cindex file archive suffix ar + +@item @samp{.cab}, @samp{.CAB} --- +Microsoft Windows cabinets +@cindex cab, file archive suffix +@cindex CAB, file archive suffix +@cindex file archive suffix cab +@cindex file archive suffix CAB + +@item @samp{.cpio} --- +CPIO archives +@cindex cpio, file archive suffix +@cindex file archive suffix cpio + +@item @samp{.deb} --- +Debian packages +@cindex deb, file archive suffix +@cindex file archive suffix deb + +@item @samp{.depot} --- +HP-UX SD depots +@cindex depot, file archive suffix +@cindex file archive suffix depot + +@item @samp{.exe} --- +Self extracting Microsoft Windows EXE files +@cindex exe, file archive suffix +@cindex file archive suffix exe + +@item @samp{.iso} --- +ISO 9660 images +@cindex iso, file archive suffix +@cindex file archive suffix iso + +@item @samp{.jar} --- +Java archives +@cindex jar, file archive suffix +@cindex file archive suffix jar + +@item @samp{.lzh}, @samp{LZH} --- +Microsoft Windows compressed LHA archives +@cindex lzh, file archive suffix +@cindex LZH, file archive suffix +@cindex file archive suffix lzh +@cindex file archive suffix LZH + +@item @samp{.mtree} --- +BSD mtree format +@cindex mtree, file archive suffix +@cindex file archive suffix mtree + +@item @samp{.pax} --- +Posix archives +@cindex pax, file archive suffix +@cindex file archive suffix pax + +@item @samp{.rar} --- +RAR archives +@cindex rar, file archive suffix +@cindex file archive suffix rar + +@item @samp{.rpm} --- +Red Hat packages +@cindex rpm, file archive suffix +@cindex file archive suffix rpm + +@item @samp{.shar} --- +Shell archives +@cindex shar, file archive suffix +@cindex file archive suffix shar + +@item @samp{.tar}, @samp{tbz}, @samp{tgz}, @samp{tlz}, @samp{txz} --- +(Compressed) tape archives +@cindex tar, file archive suffix +@cindex tbz, file archive suffix +@cindex tgz, file archive suffix +@cindex tlz, file archive suffix +@cindex txz, file archive suffix +@cindex file archive suffix tar +@cindex file archive suffix tbz +@cindex file archive suffix tgz +@cindex file archive suffix tlz +@cindex file archive suffix txz + +@item @samp{.warc} --- +Web archives +@cindex warc, file archive suffix +@cindex file archive suffix warc + +@item @samp{.xar} --- +macOS XAR archives +@cindex xar, file archive suffix +@cindex file archive suffix xar + +@item @samp{.xps} --- +Open XML Paper Specification (OpenXPS) documents +@cindex xps, file archive suffix +@cindex file archive suffix xps + +@item @samp{.zip}, @samp{.ZIP} --- +ZIP archives +@cindex zip, file archive suffix +@cindex ZIP, file archive suffix +@cindex file archive suffix zip +@cindex file archive suffix ZIP +@end itemize + +@vindex tramp-archive-compression-suffixes +File archives could also be compressed, identified by an additional +compression suffix. Valid compression suffixes are listed in the +constant @code{tramp-archive-compression-suffixes}. They are +@samp{.bz2}, @samp{.gz}, @samp{.lrz}, @samp{.lz}, @samp{.lz4}, +@samp{.lzma}, @samp{.lzo}, @samp{.uu}, @samp{.xz} and @samp{.Z}. A +valid archive file name would be +@file{/path/to/dir/file.tar.gz/dir/file}. Even several suffixes in a +row are possible, like @file{/path/to/dir/file.tar.gz.uu/dir/file}. + +@vindex tramp-archive-all-gvfs-methods +An archive file name could be a remote file name, as in +@file{/ftp:anonymous@@ftp.gnu.org:/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL}. +Since all file operations are mapped internally to GVFS operations, +remote file names supported by @code{tramp-gvfs} perform better, +because no local copy of the file archive must be downloaded first. +For example, @samp{/sftp:user@@host:...} performs better than the +similar @samp{/scp:user@@host:...}. See the constant +@code{tramp-archive-all-gvfs-methods} for a complete list of +@code{tramp-gvfs} supported method names. + +If @code{url-handler-mode} is enabled, archives could be visited via +URLs, like @file{https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL}. +This allows complex file operations like + +@lisp +@group +(ediff-directories + "https://ftp.gnu.org/gnu/tramp/tramp-2.3.1.tar.gz/tramp-2.3.1" + "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/tramp-2.3.2" "") +@end group +@end lisp + +It is even possible to access file archives in file archives, as + +@lisp +@group +(find-file + "http://ftp.debian.org/debian/pool/main/c/coreutils/coreutils_8.28-1_amd64.deb/control.tar.gz/control") +@end group +@end lisp + + @node Bug Reports @chapter Reporting Bugs and Problems @cindex bug reports @@ -2997,7 +3206,8 @@ Where is the latest @value{tramp}? @item Which systems does it work on? -The package works successfully on Emacs 24, Emacs 25, and Emacs 26. +The package works successfully on Emacs 24, Emacs 25, Emacs 26, and +Emacs 27. While Unix and Unix-like systems are the primary remote targets, @value{tramp} has equal success connecting to other platforms, such as diff --git a/etc/NEWS b/etc/NEWS index cbd50f0227..0165768bc1 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -125,6 +125,12 @@ To restore the old behavior, use * New Modes and Packages in Emacs 27.1 ++++ +** The package tramp-archive.el brings file name handler support for +file archives. It works on systems which support GVFS, which is +GNU/Linux, roughly spoken. See the chapter "(tramp) Archive file +names" in the Tramp manual for full documentation of these facilities. + * Incompatible Lisp Changes in Emacs 27.1 diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el new file mode 100644 index 0000000000..d1e4804bf9 --- /dev/null +++ b/lisp/net/tramp-archive.el @@ -0,0 +1,556 @@ +;;; tramp-archive.el --- Tramp archive manager -*- lexical-binding:t -*- + +;; Copyright (C) 2017 Free Software Foundation, Inc. + +;; Author: Michael Albinus +;; Keywords: comm, processes +;; Package: tramp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Access functions for file archives. This is possible only on +;; machines which have installed the virtual file system for the Gnome +;; Desktop (GVFS). Internally, file archives are mounted via the GVFS +;; "archive" method. + +;; A file archive is a regular file of kind "/path/to/dir/file.EXT". +;; The extension ".EXT" identifies the type of the file archive. A +;; file inside a file archive, called archive file name, has the name +;; "/path/to/dir/file.EXT/dir/file". + +;; Most of the magic file name operations are implemented for archive +;; file names, exceptions are all operations which write into a file +;; archive, and process related operations. Therefore, functions like + +;; (copy-file "/path/to/dir/file.tar/dir/file" "/somewhere/else") + +;; work out of the box. This is also true for file name completion, +;; and for libraries like `dired' or `ediff', which accept archive +;; file names as well. + +;; File archives are identified by the file name extension ".EXT". +;; Since GVFS uses internally the library libarchive(3), all suffixes, +;; which are accepted by this library, work also for archive file +;; names. Accepted suffixes are listed in the constant +;; `tramp-archive-suffixes'. They are + +;; * ".7z" - 7-Zip archives +;; * ".apk" - Android package kits +;; * ".ar" - UNIX archiver formats +;; * ".cab", ".CAB" - Microsoft Windows cabinets +;; * ".cpio" - CPIO archives +;; * ".deb" - Debian packages +;; * ".depot" - HP-UX SD depots +;; * ".exe" - Self extracting Microsoft Windows EXE files +;; * ".iso" - ISO 9660 images +;; * ".jar" - Java archives +;; * ".lzh", "LZH" - Microsoft Windows compressed LHA archives +;; * ".mtree" - BSD mtree format +;; * ".pax" - Posix archives +;; * ".rar" - RAR archives +;; * ".rpm" - Red Hat packages +;; * ".shar" - Shell archives +;; * ".tar", "tbz", "tgz", "tlz", "txz" - (Compressed) tape archives +;; * ".warc" - Web archives +;; * ".xar" - macOS XAR archives +;; * ".xps" - Open XML Paper Specification (OpenXPS) documents +;; * ".zip", ".ZIP" - ZIP archives + +;; File archives could also be compressed, identified by an additional +;; compression suffix. Valid compression suffixes are listed in the +;; constant `tramp-archive-compression-suffixes'. They are ".bz2", +;; ".gz", ".lrz", ".lz", ".lz4", ".lzma", ".lzo", ".uu", ".xz" and +;; ".Z". A valid archive file name would be +;; "/path/to/dir/file.tar.gz/dir/file". Even several suffixes in a +;; row are possible, like "/path/to/dir/file.tar.gz.uu/dir/file". + +;; An archive file name could be a remote file name, as in +;; "/ftp:anonymous@ftp.gnu.org:/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL". +;; Since all file operations are mapped internally to GVFS operations, +;; remote file names supported by tramp-gvfs.el perform better, +;; because no local copy of the file archive must be downloaded first. +;; For example, "/sftp:user@host:..." performs better than the similar +;; "/scp:user@host:...". See the constant +;; `tramp-archive-all-gvfs-methods' for a complete list of +;; tramp-gvfs.el supported method names. + +;; If `url-handler-mode' is enabled, archives could be visited via +;; URLs, like "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL". +;; This allows complex file operations like + +;; (ediff-directories +;; "https://ftp.gnu.org/gnu/tramp/tramp-2.3.1.tar.gz/tramp-2.3.1" +;; "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/tramp-2.3.2" "") + +;; It is even possible to access file archives in file archives, as + +;; (find-file +;; "http://ftp.debian.org/debian/pool/main/c/coreutils/coreutils_8.28-1_amd64.deb/control.tar.gz/control") + +;;; Code: + +(require 'tramp-gvfs) + +(autoload 'dired-uncache "dired") +(autoload 'url-tramp-convert-url-to-tramp "url-tramp") +(defvar url-handler-mode-hook) +(defvar url-handler-regexp) +(defvar url-tramp-protocols) + +;; +;;;###tramp-autoload +(defconst tramp-archive-suffixes + ;; "cab", "lzh" and "zip" are included with lower and upper letters, + ;; because Microsoft Windows provides them often with capital + ;; letters. + '("7z" ;; 7-Zip archives. + "apk" ;; Android package kits. Not in libarchive testsuite. + "ar" ;; UNIX archiver formats. + "cab" "CAB" ;; Microsoft Windows cabinets. + "cpio" ;; CPIO archives. + "deb" ;; Debian packages. Not in libarchive testsuite. + "depot" ;; HP-UX SD depot. Not in libarchive testsuite. + "exe" ;; Self extracting Microsoft Windows EXE files. + "iso" ;; ISO 9660 images. + "jar" ;; Java archives. Not in libarchive testsuite. + "lzh" "LZH" ;; Microsoft Windows compressed LHA archives. + "mtree" ;; BSD mtree format. + "pax" ;; Posix archives. + "rar" ;; RAR archives. + "rpm" ;; Red Hat packages. + "shar" ;; Shell archives. Not in libarchive testsuite. + "tar" "tbz" "tgz" "tlz" "txz" ;; (Compressed) tape archives. + "warc" ;; Web archives. + "xar" ;; macOS XAR archives. Not in libarchive testsuite. + "xps" ;; Open XML Paper Specification (OpenXPS) documents. + "zip" "ZIP") ;; ZIP archives. + "List of suffixes which indicate a file archive. +It must be supported by libarchive(3).") + +;; +;; read and write: tar, cpio, pax , gzip , zip, bzip2, xz, lzip, lzma, ar, mtree, iso9660, compress, +;; read only: 7-Zip, mtree, xar, lha/lzh, rar, microsoft cab, + +;;;###tramp-autoload +(defconst tramp-archive-compression-suffixes + '("bz2" "gz" "lrz" "lz" "lz4" "lzma" "lzo" "uu" "xz" "Z") + "List of suffixes which indicate a compressed file. +It must be supported by libarchive(3).") + +;;;###tramp-autoload +(defconst tramp-archive-file-name-regexp + (concat + "\\`" "\\(" ".+" "\\." + ;; Default suffixes ... + (regexp-opt tramp-archive-suffixes) + ;; ... with compression. + "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*" + "\\)" ;; \1 + "\\(" "/" ".*" "\\)" "\\'") ;; \2 + "Regular expression matching archive file names.") + +;;;###tramp-autoload +(defconst tramp-archive-method "archive" + "Method name for archives in GVFS.") + +(defconst tramp-archive-all-gvfs-methods + (cons tramp-archive-method + (let ((values (cdr (cadr (get 'tramp-gvfs-methods 'custom-type))))) + (setq values (mapcar 'last values) + values (mapcar 'car values)))) + "List of all methods `tramp-gvfs-methods' offers.") + + +;; New handlers should be added here. +;;;###tramp-autoload +(defconst tramp-archive-file-name-handler-alist + '((access-file . ignore) + (add-name-to-file . tramp-archive-handle-not-implemented) + ;; `byte-compiler-base-file-name' performed by default handler. + ;; `copy-directory' performed by default handler. + (copy-file . tramp-archive-handle-copy-file) + (delete-directorye . tramp-archive-handle-not-implemented) + (delete-file . tramp-archive-handle-not-implemented) + ;; `diff-latest-backup-file' performed by default handler. + (directory-file-name . tramp-archive-handle-directory-file-name) + (directory-files . tramp-handle-directory-files) + (directory-files-and-attributes + . tramp-handle-directory-files-and-attributes) + (dired-compress-file . tramp-archive-handle-not-implemented) + (dired-uncache . tramp-archive-handle-dired-uncache) + ;; `expand-file-name' performed by default handler. + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) + (file-acl . ignore) + (file-attributes . tramp-archive-handle-file-attributes) + (file-directory-p . tramp-handle-file-directory-p) + (file-equal-p . tramp-handle-file-equal-p) + (file-executable-p . tramp-archive-handle-file-executable-p) + (file-exists-p . tramp-handle-file-exists-p) + (file-in-directory-p . tramp-handle-file-in-directory-p) + (file-local-copy . tramp-archive-handle-file-local-copy) + (file-modes . tramp-handle-file-modes) + (file-name-all-completions . tramp-archive-handle-file-name-all-completions) + ;; `file-name-as-directory' performed by default handler. + (file-name-case-insensitive-p . ignore) + (file-name-completion . tramp-handle-file-name-completion) + ;; `file-name-directory' performed by default handler. + ;; `file-name-nondirectory' performed by default handler. + ;; `file-name-sans-versions' performed by default handler. + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) + (file-notify-add-watch . ignore) + (file-notify-rm-watch . ignore) + (file-notify-valid-p . ignore) + (file-ownership-preserved-p . ignore) + (file-readable-p . tramp-archive-handle-file-readable-p) + (file-regular-p . tramp-handle-file-regular-p) + ;; `file-remote-p' performed by default handler. + (file-selinux-context . tramp-handle-file-selinux-context) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-system-info . tramp-archive-handle-file-system-info) + (file-truename . tramp-archive-handle-file-truename) + (file-writable-p . ignore) + (find-backup-file-name . ignore) + ;; `find-file-noselect' performed by default handler. + ;; `get-file-buffer' performed by default handler. + (insert-directory . tramp-archive-handle-insert-directory) + (insert-file-contents . tramp-archive-handle-insert-file-contents) + (load . tramp-archive-handle-load) + (make-auto-save-file-name . ignore) + (make-directory . tramp-archive-handle-not-implemented) + (make-directory-internal . tramp-archive-handle-not-implemented) + (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-symbolic-link . tramp-archive-handle-not-implemented) + (process-file . ignore) + (rename-file . tramp-archive-handle-not-implemented) + (set-file-acl . ignore) + (set-file-modes . tramp-archive-handle-not-implemented) + (set-file-selinux-context . ignore) + (set-file-times . tramp-archive-handle-not-implemented) + (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) + (shell-command . tramp-archive-handle-not-implemented) + (start-file-process . tramp-archive-handle-not-implemented) + ;; `substitute-in-file-name' performed by default handler. + ;; `temporary-file-directory' performed by default handler. + (unhandled-file-name-directory . ignore) + (vc-registered . ignore) + (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (write-region . tramp-archive-handle-not-implemented)) + "Alist of handler functions for GVFS archive method. +Operations not mentioned here will be handled by the default Emacs primitives.") + +;;;###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)))) + +;; Mark `operations' the handler is responsible for. +(put 'tramp-archive-file-name-handler 'operations + (mapcar 'car tramp-archive-file-name-handler-alist)) + +;; `tramp-archive-file-name-handler' must be placed before `url-file-handler'. +(when url-handler-mode (tramp-register-file-name-handlers)) + +(eval-after-load 'url-handler + (progn + (add-hook 'url-handler-mode-hook 'tramp-register-file-name-handlers) + (add-hook + 'tramp-archive-unload-hook + (lambda () + (remove-hook + 'url-handler-mode-hook 'tramp-register-file-name-handlers))))) + +;; Debug. +;(trace-function-background 'tramp-archive-file-name-handler) +;(trace-function-background 'tramp-gvfs-file-name-handler) +;(trace-function-background 'tramp-file-name-archive) +;(trace-function-background 'tramp-archive-dissect-file-name) + + +;; File name conversions. + +(defun tramp-archive-file-name-p (name) + "Return t if NAME is a string with archive file name syntax." + (and (stringp name) + (string-match tramp-archive-file-name-regexp name) + 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" + (cond + ;; 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)) + ;; http://... + ((and url-handler-mode + tramp-compat-use-url-tramp-p + (string-match url-handler-regexp archive) + (string-match "https?" (url-type (url-generic-parse-url archive)))) + (let* ((url-tramp-protocols + (cons + (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)) + ;; GVFS supported schemes. + ((or (tramp-gvfs-file-name-p archive) + (not (file-remote-p archive))) + (puthash archive nil tramp-archive-hash) + archive) + ;; 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)))))) + +;;;###tramp-autoload +(defun tramp-archive-cleanup-hash () + "Remove local copies of archives, used by GVFS." + (maphash + (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))))) + ;; Delete local copy. + (ignore-errors (when value (delete-file value))) + (remhash key tramp-archive-hash)) + tramp-archive-hash) + (clrhash tramp-archive-hash)) + +(add-hook 'kill-emacs-hook 'tramp-archive-cleanup-hash) +(add-hook 'tramp-archive-unload-hook + (lambda () + (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 +`tramp-archive-method', and the host being a coded URL. The +archive name is extracted from the hop part of the VEC structure." + (and (tramp-file-name-p vec) + (string-equal (tramp-file-name-method vec) tramp-archive-method) + (tramp-file-name-hop vec))) + +(defmacro with-parsed-tramp-archive-file-name (filename var &rest body) + "Parse an archive filename and make components available in the body. +This works exactly as `with-parsed-tramp-file-name' for the Tramp +file name structure returned by `tramp-archive-dissect-file-name'. +A variable `foo-archive' (or `archive') will be bound to the +archive name part of FILENAME, assuming `foo' (or nil) is the +value of VAR. OTOH, the variable `foo-hop' (or `hop') won't be +offered." + (declare (debug (form symbolp body)) + (indent 2)) + (let ((bindings + (mapcar (lambda (elem) + `(,(if var (intern (format "%s-%s" var elem)) elem) + (,(intern (format "tramp-file-name-%s" elem)) + ,(or var 'v)))) + `,(cons + 'archive + (delete 'hop (tramp-compat-tramp-file-name-slots)))))) + `(let* ((,(or var 'v) (tramp-archive-dissect-file-name ,filename)) + ,@bindings) + ;; We don't know which of those vars will be used, so we bind them all, + ;; and then add here a dummy use of all those variables, so we don't get + ;; flooded by warnings about those vars `body' didn't use. + (ignore ,@(mapcar #'car bindings)) + ,@body))) + +(defun tramp-archive-gvfs-file-name (name) + "Return FILENAME in GVFS syntax." + (tramp-make-tramp-file-name + (tramp-archive-dissect-file-name name) nil 'nohop)) + + +;; File name primitives. + +(defun tramp-archive-handle-copy-file + (filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Like `copy-file' for file archives." + (when (tramp-archive-file-name-p newname) + (tramp-error + (tramp-archive-dissect-file-name newname) 'file-error + "Permission denied: %s" newname)) + (copy-file + (tramp-archive-gvfs-file-name filename) newname ok-if-already-exists + keep-date preserve-uid-gid preserve-extended-attributes)) + +(defun tramp-archive-handle-directory-file-name (directory) + "Like `directory-file-name' for file archives." + (with-parsed-tramp-archive-file-name directory nil + (if (and (not (zerop (length localname))) + (eq (aref localname (1- (length localname))) ?/) + (not (string= localname "/"))) + (substring directory 0 -1) + ;; We do not want to leave the file archive. This would require + ;; unnecessary download of http-based file archives, for + ;; example. So we return `directory'. + directory))) + +(defun tramp-archive-handle-dired-uncache (dir) + "Like `dired-uncache' for file archives." + (dired-uncache (tramp-archive-gvfs-file-name dir))) + +(defun tramp-archive-handle-file-attributes (filename &optional id-format) + "Like `file-attributes' for file archives." + (file-attributes (tramp-archive-gvfs-file-name filename) id-format)) + +(defun tramp-archive-handle-file-executable-p (filename) + "Like `file-executable-p' for file archives." + (file-executable-p (tramp-archive-gvfs-file-name filename))) + +(defun tramp-archive-handle-file-local-copy (filename) + "Like `file-local-copy' for file archives." + (file-local-copy (tramp-archive-gvfs-file-name filename))) + +(defun tramp-archive-handle-file-name-all-completions (filename directory) + "Like `file-name-all-completions' for file archives." + (file-name-all-completions filename (tramp-archive-gvfs-file-name directory))) + +(defun tramp-archive-handle-file-readable-p (filename) + "Like `file-readable-p' for file archives." + (with-parsed-tramp-file-name + (tramp-archive-gvfs-file-name filename) nil + (tramp-check-cached-permissions v ?r))) + +(defun tramp-archive-handle-file-system-info (filename) + "Like `file-system-info' for file archives." + (with-parsed-tramp-archive-file-name filename nil + (list (tramp-compat-file-attribute-size (file-attributes archive)) 0 0))) + +(defun tramp-archive-handle-file-truename (filename) + "Like `file-truename' for file archives." + (with-parsed-tramp-archive-file-name filename nil + (let ((local (or (file-symlink-p filename) localname))) + (unless (file-name-absolute-p local) + (setq local (expand-file-name local (file-name-directory localname)))) + (concat (file-truename archive) local)))) + +(defun tramp-archive-handle-insert-directory + (filename switches &optional wildcard full-directory-p) + "Like `insert-directory' for file archives." + (insert-directory + (tramp-archive-gvfs-file-name filename) switches wildcard full-directory-p) + (goto-char (point-min)) + (while (search-forward (tramp-archive-gvfs-file-name filename) nil 'noerror) + (replace-match filename))) + +(defun tramp-archive-handle-insert-file-contents + (filename &optional visit beg end replace) + "Like `insert-file-contents' for file archives." + (let ((result + (insert-file-contents + (tramp-archive-gvfs-file-name filename) visit beg end replace))) + (prog1 + (list (expand-file-name filename) + (cadr result)) + (when visit (setq buffer-file-name filename))))) + +(defun tramp-archive-handle-load + (file &optional noerror nomessage nosuffix must-suffix) + "Like `load' for file archives." + (load + (tramp-archive-gvfs-file-name file) noerror nomessage nosuffix must-suffix)) + +(defun tramp-archive-handle-not-implemented (operation &rest args) + "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))))) + (tramp-message v 10 "%s" (cons operation args)) + (tramp-error + v 'file-error + "Operation `%s' not implemented for file archives" operation))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-archive 'force))) + +(provide 'tramp-archive) + +;;; TODO: + +;; * See, whether we could retrieve better file attributes like uid, +;; gid, permissions. +;; +;; * Implement write access, when possible. + +;;; tramp-archive.el ends here diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 87ec3c2a13..bd746c1a99 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -384,6 +384,8 @@ used to cache connection properties of the local machine." (maphash (lambda (key value) (if (and (tramp-file-name-p key) value + (not (string-equal + (tramp-file-name-method key) tramp-archive-method)) (not (tramp-file-name-localname key)) (not (gethash "login-as" value)) (not (gethash "started" value))) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 35c00a0155..1f72e255c4 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -143,6 +143,9 @@ This includes password cache, file cache, connection cache, buffers." ;; Flush file and connection cache. (clrhash tramp-cache-data) + ;; Cleanup local copies of archives. + (tramp-archive-cleanup-hash) + ;; Remove buffers. (dolist (name (tramp-list-tramp-buffers)) (when (bufferp (get-buffer name)) (kill-buffer name)))) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 9cdfc06512..a9e9ce85d6 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -190,11 +190,6 @@ This is a string of ten letters or dashes as in ls -l." (if (get 'file-missing 'error-conditions) 'file-missing 'file-error) "The error symbol for the `file-missing' error.") -(add-hook 'tramp-unload-hook - (lambda () - (unload-feature 'tramp-loaddefs 'force) - (unload-feature 'tramp-compat 'force))) - ;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' are ;; introduced in Emacs 26. (eval-and-compile @@ -243,6 +238,17 @@ If NAME is a remote file name, the local part of NAME is unquoted." `(cdr (mapcar 'car (cl-struct-slot-info 'tramp-file-name))) `(cdr (mapcar 'car (get 'tramp-file-name 'cl-struct-slots))))) +;; The signature of `tramp-make-tramp-file-name' has been changed. +;; Therefore, we cannot us `url-tramp-convert-url-to-tramp' prior +;; Emacs 26.1. We use `temporary-file-directory' as indicator. +(defconst tramp-compat-use-url-tramp-p (fboundp 'temporary-file-directory) + "Whether to use url-tramp.el.") + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-loaddefs 'force) + (unload-feature 'tramp-compat 'force))) + (provide 'tramp-compat) ;;; TODO: diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index d862e957ce..a1d50b6f2e 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -54,10 +54,12 @@ ;; device, if it hasn't been done already. There might be also some ;; few seconds delay in discovering available bluetooth devices. -;; Other possible connection methods are "ftp" and "smb". When one of -;; these methods is added to the list, the remote access for that -;; method is performed via GVFS instead of the native Tramp -;; implementation. +;; Other possible connection methods are "ftp", "http", "https" and +;; "smb". When one of these methods is added to the list, the remote +;; access for that method is performed via GVFS instead of the native +;; Tramp implementation. However, this is not recommended. These +;; methods are listed here for the benefit of file archives, see +;; tramp-archive.el. ;; GVFS offers even more connection methods. The complete list of ;; connection methods of the actual GVFS implementation can be @@ -119,6 +121,8 @@ (const "davs") (const "ftp") (const "gdrive") + (const "http") + (const "https") (const "obex") (const "sftp") (const "smb") @@ -424,6 +428,7 @@ Every entry is a list (NAME ADDRESS).") ("gvfs-ls" . "list") ("gvfs-mkdir" . "mkdir") ("gvfs-monitor-file" . "monitor") + ("gvfs-mount" . "mount") ("gvfs-move" . "move") ("gvfs-rm" . "remove") ("gvfs-trash" . "trash")) @@ -1455,6 +1460,8 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (cadr (assoc "port" (cadr mount-spec))))) (ssl (tramp-gvfs-dbus-byte-array-to-string (cadr (assoc "ssl" (cadr mount-spec))))) + (uri (tramp-gvfs-dbus-byte-array-to-string + (cadr (assoc "uri" (cadr mount-spec))))) (prefix (concat (tramp-gvfs-dbus-byte-array-to-string (car mount-spec)) @@ -1469,6 +1476,12 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (setq method "davs")) (when (string-equal "google-drive" method) (setq method "gdrive")) + (when (and (string-equal "http" method) (stringp uri)) + (setq uri (url-generic-parse-url uri) + method (url-type uri) + user (url-user uri) + host (url-host uri) + port (url-portspec uri))) (with-parsed-tramp-file-name (tramp-make-tramp-file-name method user domain host port "") nil (tramp-message @@ -1537,6 +1550,8 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (cadr (assoc "port" (cadr mount-spec))))) (ssl (tramp-gvfs-dbus-byte-array-to-string (cadr (assoc "ssl" (cadr mount-spec))))) + (uri (tramp-gvfs-dbus-byte-array-to-string + (cadr (assoc "uri" (cadr mount-spec))))) (prefix (concat (tramp-gvfs-dbus-byte-array-to-string (car mount-spec)) @@ -1554,6 +1569,12 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (setq method "gdrive")) (when (and (string-equal "synce" method) (zerop (length user))) (setq user (or (tramp-file-name-user vec) ""))) + (when (and (string-equal "http" method) (stringp uri)) + (setq uri (url-generic-parse-url uri) + method (url-type uri) + user (url-user uri) + host (url-host uri) + port (url-portspec uri))) (when (and (string-equal method (tramp-file-name-method vec)) (string-equal user (tramp-file-name-user vec)) @@ -1570,6 +1591,16 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." vec "default-location" default-location) (throw 'mounted t))))))) +(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)))))) + (defun tramp-gvfs-mount-spec-entry (key value) "Construct a mount-spec entry to be used in a mount_spec. It was \"a(say)\", but has changed to \"a{sv})\"." @@ -1611,7 +1642,14 @@ It was \"a(say)\", but has changed to \"a{sv})\"." ((string-equal "gdrive" method) (list (tramp-gvfs-mount-spec-entry "type" "google-drive") (tramp-gvfs-mount-spec-entry "host" host))) - (t + ((string-match "\\`http" method) + (list (tramp-gvfs-mount-spec-entry "type" "http") + (tramp-gvfs-mount-spec-entry + "uri" + (url-recreate-url + (url-parse-make-urlobj + method user nil host port "/" nil nil t))))) + (t (list (tramp-gvfs-mount-spec-entry "type" method) (tramp-gvfs-mount-spec-entry "host" host)))) ,@(when user @@ -2033,6 +2071,8 @@ They are retrieved from the hal daemon." ;;; TODO: +;; * (Customizable) unmount when exiting Emacs. See tramp-archive.el. + ;; * Host name completion for existing mount points (afp-server, ;; smb-server) or via smb-network. ;; diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index b933778447..c73ec1de30 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2064,6 +2064,7 @@ pass to the OPERATION." `(tramp-file-name-handler tramp-vc-file-name-handler tramp-completion-file-name-handler + tramp-archive-file-name-handler cygwin-mount-name-hook-function cygwin-mount-map-drive-hook-function . @@ -2369,12 +2370,14 @@ remote file names." ;; loading of Tramp. (dolist (fnh '(tramp-file-name-handler tramp-completion-file-name-handler + tramp-archive-file-name-handler tramp-autoload-file-name-handler)) (let ((a1 (rassq fnh file-name-handler-alist))) (setq file-name-handler-alist (delq a1 file-name-handler-alist)))) ;; Add the handlers. We do not add anything to the `operations' - ;; property of `tramp-file-name-handler', this shall be done by the + ;; property of `tramp-file-name-handler' and + ;; `tramp-archive-file-name-handler', this shall be done by the ;; respective foreign handlers. (add-to-list 'file-name-handler-alist (cons tramp-file-name-regexp 'tramp-file-name-handler)) @@ -2388,6 +2391,11 @@ remote file names." (put 'tramp-completion-file-name-handler 'operations (mapcar 'car tramp-completion-file-name-handler-alist)) + (add-to-list 'file-name-handler-alist + (cons tramp-archive-file-name-regexp + 'tramp-archive-file-name-handler)) + (put 'tramp-archive-file-name-handler 'safe-magic t) + ;; If jka-compr or epa-file are already loaded, move them to the ;; front of `file-name-handler-alist'. (dolist (fnh '(epa-file-handler jka-compr-handler)) @@ -2441,6 +2449,7 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." "Unload Tramp file name handlers from `file-name-handler-alist'." (dolist (fnh '(tramp-file-name-handler tramp-completion-file-name-handler + tramp-archive-file-name-handler tramp-autoload-file-name-handler)) (let ((a1 (rassq fnh file-name-handler-alist))) (setq file-name-handler-alist (delq a1 file-name-handler-alist)))))) @@ -3100,10 +3109,6 @@ User is always nil." (defun tramp-handle-file-name-completion (filename directory &optional predicate) "Like `file-name-completion' for Tramp files." - (unless (tramp-tramp-file-p directory) - (error - "tramp-handle-file-name-completion invoked on non-tramp directory `%s'" - directory)) (let (hits-ignored-extensions) (or (try-completion 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 0000000000..5716ca5987 --- /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 0000000000..257cc5642c --- /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 0000000000..996f1789ff --- /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 0000000000..68925b147f 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 0000000000..257cc5642c --- /dev/null +++ b/test/lisp/net/tramp-archive-resources/foo.txt @@ -0,0 +1 @@ +foo diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el new file mode 100644 index 0000000000..bbe7d4c9aa --- /dev/null +++ b/test/lisp/net/tramp-archive-tests.el @@ -0,0 +1,796 @@ +;;; tramp-archive-tests.el --- Tests of file archive access -*- lexical-binding:t -*- + +;; Copyright (C) 2017 Free Software Foundation, Inc. + +;; Author: Michael Albinus + +;; 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 the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `https://www.gnu.org/licenses/'. + +;;; Code: + +(require 'ert) +(require 'tramp-archive) + +(defconst tramp-archive-test-resource-directory + (let ((default-directory + (if load-in-progress + (file-name-directory load-file-name) + default-directory))) + (cond + ((file-accessible-directory-p (expand-file-name "resources")) + (expand-file-name "resources")) + ((file-accessible-directory-p (expand-file-name "tramp-archive-resources")) + (expand-file-name "tramp-archive-resources")))) + "The resources directory test files are located in.") + +(defconst tramp-archive-test-file-archive + (file-truename + (expand-file-name "foo.tar.gz" tramp-archive-test-resource-directory)) + "The test file archive.") + +(defconst tramp-archive-test-archive + (file-name-as-directory tramp-archive-test-file-archive) + "The test archive.") + +(setq password-cache-expiry nil + tramp-verbose 0 + tramp-cache-read-persistent-data t ;; For auth-sources. + tramp-copy-size-limit nil + tramp-message-show-message nil + tramp-persistency-file-name nil) + +(defun tramp-archive--test-make-temp-name () + "Return a temporary file name for test. +The temporary file is not created." + (expand-file-name + (make-temp-name "tramp-archive-test") temporary-file-directory)) + +(defun tramp-archive--test-delete (tmpfile) + "Delete temporary file or directory TMPFILE. +This needs special support, because archive file names, which are +the origin of the temporary TMPFILE, have no write permissions." + (unless (file-writable-p (file-name-directory tmpfile)) + (set-file-modes + (file-name-directory tmpfile) + (logior (file-modes (file-name-directory tmpfile)) #o0700))) + (set-file-modes tmpfile #o0700) + (if (file-regular-p tmpfile) + (delete-file tmpfile) + (mapc + 'tramp-archive--test-delete + (directory-files tmpfile 'full directory-files-no-dot-files-regexp)) + (delete-directory tmpfile))) + +(defun tramp-archive--test-emacs26-p () + "Check for Emacs version >= 26.1. +Some semantics has been changed for there, w/o new functions or +variables, so we check the Emacs version directly." + (>= emacs-major-version 26)) + +(ert-deftest tramp-archive-test00-availability () + "Test availability of Tramp functions." + :expected-result (if tramp-gvfs-enabled :passed :failed) + (should + (and + tramp-gvfs-enabled + (file-exists-p tramp-archive-test-file-archive) + (tramp-archive-file-name-p tramp-archive-test-archive)))) + +(ert-deftest tramp-archive-test01-file-name-syntax () + "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 (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo"))) + (should + (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"))) + (should + (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo.tar/")))) + +(ert-deftest tramp-archive-test02-file-name-dissect () + "Check archive file name components." + (skip-unless tramp-gvfs-enabled) + + (with-parsed-tramp-archive-file-name tramp-archive-test-archive nil + (should (string-equal method tramp-archive-method)) + (should-not user) + (should-not domain) + (should + (string-equal + host + (file-remote-p + (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host))) + (should + (string-equal + host + (url-hexify-string (concat "file://" tramp-archive-test-file-archive)))) + (should-not port) + (should (string-equal localname "/")) + (should (string-equal archive tramp-archive-test-file-archive))) + + ;; Localname. + (with-parsed-tramp-archive-file-name + (concat tramp-archive-test-archive "foo") nil + (should (string-equal method tramp-archive-method)) + (should-not user) + (should-not domain) + (should + (string-equal + host + (file-remote-p + (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host))) + (should + (string-equal + host + (url-hexify-string (concat "file://" tramp-archive-test-file-archive)))) + (should-not port) + (should (string-equal localname "/foo")) + (should (string-equal archive tramp-archive-test-file-archive))) + + ;; File archive in file archive. + (let* ((tramp-archive-test-file-archive + (concat tramp-archive-test-archive "bar.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 + (should (string-equal method tramp-archive-method)) + (should-not user) + (should-not domain) + (should + (string-equal + host + (file-remote-p + (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host))) + ;; We reimplement the logic of tramp-archive.el here. Don't + ;; know, whether it is worth the test. + (should + (string-equal + host + (url-hexify-string + (concat + (tramp-gvfs-url-file-name + (tramp-make-tramp-file-name + tramp-archive-method + ;; User and Domain. + nil nil + ;; Host. + (url-hexify-string + (concat + "file://" + ;; `directory-file-name' does not leave file archive + ;; boundaries. So we must cut the trailing slash + ;; ourselves. + (substring + (file-name-directory tramp-archive-test-file-archive) 0 -1))) + 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))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test05-expand-file-name () + "Check `expand-file-name'." + (should + (string-equal + (expand-file-name "/foo.tar/path/./file") "/foo.tar/path/file")) + (should + (string-equal (expand-file-name "/foo.tar/path/../file") "/foo.tar/file")) + ;; `expand-file-name' does not care "~/" in archive file names. + (should + (string-equal (expand-file-name "/foo.tar/~/file") "/foo.tar/~/file")) + ;; `expand-file-name' does not care file archive boundaries. + (should (string-equal (expand-file-name "/foo.tar/./file") "/foo.tar/file")) + (should (string-equal (expand-file-name "/foo.tar/../file") "/file"))) + +(ert-deftest tramp-archive-test06-directory-file-name () + "Check `directory-file-name'. +This checks also `file-name-as-directory', `file-name-directory', +`file-name-nondirectory' and `unhandled-file-name-directory'." + (should + (string-equal + (directory-file-name "/foo.tar/path/to/file") "/foo.tar/path/to/file")) + (should + (string-equal + (directory-file-name "/foo.tar/path/to/file/") "/foo.tar/path/to/file")) + ;; `directory-file-name' does not leave file archive boundaries. + (should (string-equal (directory-file-name "/foo.tar/") "/foo.tar/")) + + (should + (string-equal + (file-name-as-directory "/foo.tar/path/to/file") "/foo.tar/path/to/file/")) + (should + (string-equal + (file-name-as-directory "/foo.tar/path/to/file/") "/foo.tar/path/to/file/")) + (should (string-equal (file-name-as-directory "/foo.tar/") "/foo.tar/")) + (should (string-equal (file-name-as-directory "/foo.tar") "/foo.tar/")) + + (should + (string-equal + (file-name-directory "/foo.tar/path/to/file") "/foo.tar/path/to/")) + (should + (string-equal + (file-name-directory "/foo.tar/path/to/file/") "/foo.tar/path/to/file/")) + (should (string-equal (file-name-directory "/foo.tar/") "/foo.tar/")) + + (should + (string-equal (file-name-nondirectory "/foo.tar/path/to/file") "file")) + (should + (string-equal (file-name-nondirectory "/foo.tar/path/to/file/") "")) + (should (string-equal (file-name-nondirectory "/foo.tar/") "")) + + (should-not + (unhandled-file-name-directory "/foo.tar/path/to/file"))) + +(ert-deftest tramp-archive-test07-file-exists-p () + "Check `file-exist-p', `write-region' and `delete-file'." + (skip-unless tramp-gvfs-enabled) + + (unwind-protect + (let ((default-directory tramp-archive-test-archive)) + (should (file-exists-p tramp-archive-test-file-archive)) + (should (file-exists-p tramp-archive-test-archive)) + (should (file-exists-p "foo.txt")) + (should (file-exists-p "foo.lnk")) + (should (file-exists-p "bar")) + (should (file-exists-p "bar/bar")) + (should-error + (write-region "foo" nil "baz") + :type 'file-error) + (should-error + (delete-file "baz") + :type 'file-error)) + + ;; Cleanup. + (tramp-archive-cleanup-hash))) + +(ert-deftest tramp-archive-test08-file-local-copy () + "Check `file-local-copy'." + (skip-unless tramp-gvfs-enabled) + + (let (tmp-name) + (unwind-protect + (progn + (should + (setq tmp-name + (file-local-copy + (expand-file-name "bar/bar" tramp-archive-test-archive)))) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "bar\n"))) + ;; Error case. + (tramp-archive--test-delete tmp-name) + (should-error + (setq tmp-name + (file-local-copy + (expand-file-name "what" tramp-archive-test-archive))) + :type tramp-file-missing)) + + ;; Cleanup. + (ignore-errors + (tramp-archive--test-delete tmp-name) + (tramp-archive-cleanup-hash))))) + +(ert-deftest tramp-archive-test09-insert-file-contents () + "Check `insert-file-contents'." + (skip-unless tramp-gvfs-enabled) + + (let ((tmp-name (expand-file-name "bar/bar" tramp-archive-test-archive))) + (unwind-protect + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "bar\n")) + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "bar\nbar\n")) + ;; Insert partly. + (insert-file-contents tmp-name nil 1 3) + (should (string-equal (buffer-string) "arbar\nbar\n")) + ;; Replace. + (insert-file-contents tmp-name nil nil nil 'replace) + (should (string-equal (buffer-string) "bar\n")) + ;; Error case. + (should-error + (insert-file-contents + (expand-file-name "what" tramp-archive-test-archive)) + :type tramp-file-missing)) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test11-copy-file () + "Check `copy-file'." + (skip-unless tramp-gvfs-enabled) + + ;; Copy simple file. + (let ((tmp-name1 (expand-file-name "bar/bar" tramp-archive-test-archive)) + (tmp-name2 (tramp-archive--test-make-temp-name))) + (unwind-protect + (progn + (copy-file tmp-name1 tmp-name2) + (should (file-exists-p tmp-name2)) + (with-temp-buffer + (insert-file-contents tmp-name2) + (should (string-equal (buffer-string) "bar\n"))) + (should-error + (copy-file tmp-name1 tmp-name2) + :type 'file-already-exists) + (copy-file tmp-name1 tmp-name2 'ok) + ;; The file archive is not writable. + (should-error + (copy-file tmp-name2 tmp-name1 'ok) + :type 'file-error)) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash))) + + ;; Copy directory to existing directory. + (let ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive)) + (tmp-name2 (tramp-archive--test-make-temp-name))) + (unwind-protect + (progn + (make-directory tmp-name2) + (should (file-directory-p tmp-name2)) + ;; Directory `tmp-name2' exists already, so we must use + ;; `file-name-as-directory'. + (copy-file tmp-name1 (file-name-as-directory tmp-name2)) + (should + (file-exists-p + (expand-file-name + (concat (file-name-nondirectory tmp-name1) "/bar") tmp-name2)))) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash))) + + ;; Copy directory/file to non-existing directory. + (let ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive)) + (tmp-name2 (tramp-archive--test-make-temp-name))) + (unwind-protect + (progn + (make-directory tmp-name2) + (should (file-directory-p tmp-name2)) + (copy-file + tmp-name1 + (expand-file-name (file-name-nondirectory tmp-name1) tmp-name2)) + (should + (file-exists-p + (expand-file-name + (concat (file-name-nondirectory tmp-name1) "/bar") tmp-name2)))) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test15-copy-directory () + "Check `copy-directory'." + (skip-unless tramp-gvfs-enabled) + + (let* ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive)) + (tmp-name2 (tramp-archive--test-make-temp-name)) + (tmp-name3 (expand-file-name + (file-name-nondirectory tmp-name1) tmp-name2)) + (tmp-name4 (expand-file-name "bar" tmp-name2)) + (tmp-name5 (expand-file-name "bar" tmp-name3))) + + ;; Copy complete directory. + (unwind-protect + (progn + ;; Copy empty directory. + (copy-directory tmp-name1 tmp-name2) + (should (file-directory-p tmp-name2)) + (should (file-exists-p tmp-name4)) + ;; Target directory does exist already. + ;; This has been changed in Emacs 26.1. + (when (tramp-archive--test-emacs26-p) + (should-error + (copy-directory tmp-name1 tmp-name2) + :type 'file-error)) + (tramp-archive--test-delete tmp-name4) + (copy-directory tmp-name1 (file-name-as-directory tmp-name2)) + (should (file-directory-p tmp-name3)) + (should (file-exists-p tmp-name5))) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash)) + + ;; Copy directory contents. + (unwind-protect + (progn + ;; Copy empty directory. + (copy-directory tmp-name1 tmp-name2 nil 'parents 'contents) + (should (file-directory-p tmp-name2)) + (should (file-exists-p tmp-name4)) + ;; Target directory does exist already. + (tramp-archive--test-delete tmp-name4) + (copy-directory + tmp-name1 (file-name-as-directory tmp-name2) + nil 'parents 'contents) + (should (file-directory-p tmp-name2)) + (should (file-exists-p tmp-name4)) + (should-not (file-directory-p tmp-name3)) + (should-not (file-exists-p tmp-name5))) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test16-directory-files () + "Check `directory-files'." + (skip-unless tramp-gvfs-enabled) + + (let ((tmp-name tramp-archive-test-archive) + (files '("." ".." "bar" "foo.hrd" "foo.lnk" "foo.txt"))) + (unwind-protect + (progn + (should (file-directory-p tmp-name)) + (should (equal (directory-files tmp-name) files)) + (should (equal (directory-files tmp-name 'full) + (mapcar (lambda (x) (concat tmp-name x)) files))) + (should (equal (directory-files + tmp-name nil directory-files-no-dot-files-regexp) + (delete "." (delete ".." files)))) + (should (equal (directory-files + tmp-name 'full directory-files-no-dot-files-regexp) + (mapcar (lambda (x) (concat tmp-name x)) + (delete "." (delete ".." files)))))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test17-insert-directory () + "Check `insert-directory'." + (skip-unless tramp-gvfs-enabled) + + (let (;; We test for the summary line. Keyword "total" could be localized. + (process-environment + (append '("LANG=C" "LANGUAGE=C" "LC_ALL=C") process-environment))) + (unwind-protect + (progn + ;; Due to Bug#29423, this works only since for Emacs 26.1. + (when nil ;; TODO (tramp-archive--test-emacs26-p) + (with-temp-buffer + (insert-directory tramp-archive-test-archive nil) + (goto-char (point-min)) + (should + (looking-at-p (regexp-quote tramp-archive-test-archive))))) + (with-temp-buffer + (insert-directory tramp-archive-test-archive "-al") + (goto-char (point-min)) + (should + (looking-at-p + (format "^.+ %s$" (regexp-quote tramp-archive-test-archive))))) + (with-temp-buffer + (insert-directory + (file-name-as-directory tramp-archive-test-archive) + "-al" nil 'full-directory-p) + (goto-char (point-min)) + (should + (looking-at-p + (concat + ;; There might be a summary line. + "\\(total.+[[:digit:]]+\n\\)?" + ;; We don't know in which order the files appear. + (format + "\\(.+ %s\\( ->.+\\)?\n\\)\\{%d\\}" + (regexp-opt (directory-files tramp-archive-test-archive)) + (length (directory-files tramp-archive-test-archive)))))))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test18-file-attributes () + "Check `file-attributes'. +This tests also `file-readable-p' and `file-regular-p'." + (skip-unless tramp-gvfs-enabled) + + (let ((tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive)) + (tmp-name2 (expand-file-name "foo.lnk" tramp-archive-test-archive)) + (tmp-name3 (expand-file-name "bar" tramp-archive-test-archive)) + attr) + (unwind-protect + (progn + (should (file-exists-p tmp-name1)) + (should (file-readable-p tmp-name1)) + (should (file-regular-p tmp-name1)) + + ;; We do not test inodes and device numbers. + (setq attr (file-attributes tmp-name1)) + (should (consp attr)) + (should (null (car attr))) + (should (numberp (nth 1 attr))) ;; Link. + (should (numberp (nth 2 attr))) ;; Uid. + (should (numberp (nth 3 attr))) ;; Gid. + ;; Last access time. + (should (stringp (current-time-string (nth 4 attr)))) + ;; Last modification time. + (should (stringp (current-time-string (nth 5 attr)))) + ;; Last status change time. + (should (stringp (current-time-string (nth 6 attr)))) + (should (numberp (nth 7 attr))) ;; Size. + (should (stringp (nth 8 attr))) ;; Modes. + + (setq attr (file-attributes tmp-name1 'string)) + (should (stringp (nth 2 attr))) ;; Uid. + (should (stringp (nth 3 attr))) ;; Gid. + + ;; Symlink. + (should (file-exists-p tmp-name2)) + (should (file-symlink-p tmp-name2)) + (setq attr (file-attributes tmp-name2)) + (should (string-equal (car attr) (file-name-nondirectory tmp-name1))) + + ;; Directory. + (should (file-exists-p tmp-name3)) + (should (file-readable-p tmp-name3)) + (should-not (file-regular-p tmp-name3)) + (setq attr (file-attributes tmp-name3)) + (should (eq (car attr) t))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test19-directory-files-and-attributes () + "Check `directory-files-and-attributes'." + (skip-unless tramp-gvfs-enabled) + + (let ((tmp-name (expand-file-name "bar" tramp-archive-test-archive)) + attr) + (unwind-protect + (progn + (should (file-directory-p tmp-name)) + (setq attr (directory-files-and-attributes tmp-name)) + (should (consp attr)) + (dolist (elt attr) + (should + (equal (file-attributes (expand-file-name (car elt) tmp-name)) + (cdr elt)))) + (setq attr (directory-files-and-attributes tmp-name 'full)) + (dolist (elt attr) + (should (equal (file-attributes (car elt)) (cdr elt)))) + (setq attr (directory-files-and-attributes tmp-name nil "^b")) + (should (equal (mapcar 'car attr) '("bar")))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test20-file-modes () + "Check `file-modes'. +This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." + (skip-unless tramp-gvfs-enabled) + + (let ((tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive)) + (tmp-name2 (expand-file-name "bar" tramp-archive-test-archive))) + (unwind-protect + (progn + (should (file-exists-p tmp-name1)) + ;; `set-file-modes' is not implemented. + (should-error + (set-file-modes tmp-name1 #o777) + :type 'file-error) + (should (= (file-modes tmp-name1) #o400)) + (should-not (file-executable-p tmp-name1)) + (should-not (file-writable-p tmp-name1)) + + (should (file-exists-p tmp-name2)) + ;; `set-file-modes' is not implemented. + (should-error + (set-file-modes tmp-name2 #o777) + :type 'file-error) + (should (= (file-modes tmp-name2) #o500)) + (should (file-executable-p tmp-name2)) + (should-not (file-writable-p tmp-name2))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test21-file-links () + "Check `file-symlink-p' and `file-truename'" + (skip-unless tramp-gvfs-enabled) + + ;; We must use `file-truename' for the file archive, because it + ;; could be located on a symlinked directory. This would let the + ;; test fail. + (let* ((tramp-archive-test-archive (file-truename tramp-archive-test-archive)) + (tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive)) + (tmp-name2 (expand-file-name "foo.lnk" tramp-archive-test-archive))) + + (unwind-protect + (progn + (should (file-exists-p tmp-name1)) + (should (string-equal tmp-name1 (file-truename tmp-name1))) + ;; `make-symbolic-link' is not implemented. + (should-error + (make-symbolic-link tmp-name1 tmp-name2) + :type 'file-error) + (should (file-symlink-p tmp-name2)) + (should + (string-equal + ;; This is "/foo.txt". + (with-parsed-tramp-archive-file-name tmp-name1 nil localname) + ;; `file-symlink-p' returns "foo.txt". Wer must expand, therefore. + (with-parsed-tramp-archive-file-name + (expand-file-name + (file-symlink-p tmp-name2) tramp-archive-test-archive) + nil + localname))) + (should-not (string-equal tmp-name2 (file-truename tmp-name2))) + (should + (string-equal (file-truename tmp-name1) (file-truename tmp-name2))) + (should (file-equal-p tmp-name1 tmp-name2))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test26-file-name-completion () + "Check `file-name-completion' and `file-name-all-completions'." + (skip-unless tramp-gvfs-enabled) + + (let ((tmp-name tramp-archive-test-archive)) + (unwind-protect + (progn + ;; 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-not (file-name-completion "a" tmp-name)) + (should + (equal + (file-name-completion "b" tmp-name 'file-directory-p) "bar/")) + (should + (equal + (sort (file-name-all-completions "fo" tmp-name) 'string-lessp) + '("foo.hrd" "foo.lnk" "foo.txt"))) + (should + (equal + (sort (file-name-all-completions "b" tmp-name) 'string-lessp) + '("bar/"))) + (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/")) + (should + (equal + (sort (file-name-all-completions "" tmp-name) 'string-lessp) + '("bar/"))))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +;; The functions were introduced in Emacs 26.1. +(ert-deftest tramp-archive-test37-make-nearby-temp-file () + "Check `make-nearby-temp-file' and `temporary-file-directory'." + (skip-unless tramp-gvfs-enabled) + ;; Since Emacs 26.1. + (skip-unless + (and (fboundp 'make-nearby-temp-file) (fboundp 'temporary-file-directory))) + + ;; `make-nearby-temp-file' and `temporary-file-directory' exists + ;; since Emacs 26.1. We don't want to see compiler warnings for + ;; older Emacsen. + (let ((default-directory tramp-archive-test-archive) + tmp-file) + ;; The file archive shall know a temporary file directory. It is + ;; not in the archive itself. + (should (stringp (with-no-warnings (temporary-file-directory)))) + (should-not + (tramp-archive-file-name-p (with-no-warnings (temporary-file-directory)))) + + ;; A temporary file or directory shall not be located in the + ;; archive itself. + (setq tmp-file + (with-no-warnings (make-nearby-temp-file "tramp-archive-test"))) + (should (file-exists-p tmp-file)) + (should (file-regular-p tmp-file)) + (should-not (tramp-archive-file-name-p tmp-file)) + (delete-file tmp-file) + (should-not (file-exists-p tmp-file)) + + (setq tmp-file + (with-no-warnings (make-nearby-temp-file "tramp-archive-test" 'dir))) + (should (file-exists-p tmp-file)) + (should (file-directory-p tmp-file)) + (should-not (tramp-archive-file-name-p tmp-file)) + (delete-directory tmp-file) + (should-not (file-exists-p tmp-file)))) + +(ert-deftest tramp-archive-test40-archive-file-system-info () + "Check that `file-system-info' returns proper values." + (skip-unless tramp-gvfs-enabled) + ;; Since Emacs 27.1. + (skip-unless (fboundp 'file-system-info)) + + ;; `file-system-info' exists since Emacs 27. We don't want to see + ;; compiler warnings for older Emacsen. + (let ((fsi (with-no-warnings (file-system-info tramp-archive-test-archive)))) + (skip-unless fsi) + (should (and (consp fsi) + (= (length fsi) 3) + (numberp (nth 0 fsi)) + ;; FREE and AVAIL are always 0. + (zerop (nth 1 fsi)) + (zerop (nth 2 fsi)))))) + +(ert-deftest tramp-archive-test41-libarchive-tests () + "Run tests of libarchive test files." + :tags '(:expensive-test) + (skip-unless tramp-gvfs-enabled) + ;; We do not want to run unless chosen explicitly. This test makes + ;; sense only in my local environment. Michael Albinus. + (skip-unless + (equal + (ert--stats-selector ert--current-run-stats) + (ert-test-name (ert-running-test)))) + + (url-handler-mode) + (unwind-protect + (dolist (dir + '("~/Downloads" "/sftp::~/Downloads" "/ssh::~/Downloads" + "http://ftp.debian.org/debian/pool/main/c/coreutils")) + (dolist + (file + '("coreutils_8.26-3_amd64.deb" + "coreutils_8.26-3ubuntu3_amd64.deb")) + (setq file (expand-file-name file dir)) + (when (file-exists-p file) + (setq file (expand-file-name "control.tar.gz/control" file)) + (message "%s" file) + (should (file-attributes (file-name-as-directory file)))))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)) + + (unwind-protect + (dolist (dir '("" "/sftp::" "/ssh::")) + (dolist + (file + (apply + 'append + (mapcar + (lambda (x) (directory-files (concat dir x) 'full "uu\\'" 'sort)) + '("~/src/libarchive-3.2.2/libarchive/test" + "~/src/libarchive-3.2.2/cpio/test" + "~/src/libarchive-3.2.2/tar/test")))) + (setq file (file-name-as-directory file)) + (cond + ((not (tramp-archive-file-name-p file)) + (message "skipped: %s" file)) + ((file-attributes file) + (message "%s" file)) + (t (message "failed: %s" file))) + (tramp-archive-cleanup-hash))) + + ;; Cleanup. + (tramp-archive-cleanup-hash))) + +(defun tramp-archive-test-all (&optional interactive) + "Run all tests for \\[tramp-archive]." + (interactive "p") + (funcall + (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) + "^tramp-archive")) + +(provide 'tramp-archive-tests) +;;; tramp-archive-tests.el ends here commit 2ffdc041b1671e064df5ae6f7ec2f5a90c9dd30c Author: Michael Albinus Date: Sat Dec 9 14:30:04 2017 +0100 * test/Makefile.in (url-tramp-test.log): Do not handle special. diff --git a/test/Makefile.in b/test/Makefile.in index ffbb065ec6..dafa0f0aa1 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -151,7 +151,6 @@ ifdef EMACS_HYDRA_CI ## On Hydra, always show logs for certain problematic tests. lisp/emacs-lisp/eieio-tests/eieio-tests.log \ lisp/net/tramp-tests.log \ -lisp/url/url-tramp-test.log \ : WRITE_LOG = 2>&1 | tee $@ endif commit 34bedf5d0b00713a2ba9baca5e025033477a0394 Author: Michael Albinus Date: Sat Dec 9 13:22:52 2017 +0100 Sync with Tramp 2.4.0-pre * doc/misc/trampver.texi: * lisp/net/trampver.el: Change version to "2.4.0-pre". * lisp/net/tramp-adb.el (tramp-adb-file-name-handler-alist): Use `tramp-handle-file-directory-p'. (tramp-adb-parse-device-names) (tramp-adb-handle-expand-file-name) (tramp-adb-handle-file-truename, tramp-adb-handle-process-file): Adapt `tramp-make-tramp-file-name' call. (tramp-adb-handle-file-directory-p): Remove. (tramp-adb-maybe-open-connection): Do not set tramp-current-*. * lisp/net/tramp-cache.el (tramp-get-hash-table): Adapt `tramp-make-tramp-file-name' call. * lisp/net/tramp-cmds.el (tramp-cleanup-connection): Do not set tramp-current-*. * lisp/net/tramp-gvfs.el (tramp-gvfs-file-name-handler-alist): Use `tramp-handle-file-directory-p'. (tramp-gvfs-dbus-event-error): Trace with verbosity 6. (tramp-gvfs-do-copy-or-rename-file): Use `file-truename'. (tramp-gvfs-handle-file-directory-p): Remove. (tramp-gvfs-handler-askpassword): Do not set tramp-current-*. * lisp/net/tramp-sh.el (tramp-do-copy-or-rename-file-out-of-band) (tramp-sh-handle-start-file-process) (tramp-maybe-open-connection, tramp-get-remote-path): Do not set tramp-current-*. (tramp-maybe-open-connection): Set "password-vector" property. * lisp/net/tramp-smb.el (tramp-smb-file-name-handler-alist): Use `tramp-handle-file-accessible-directory-p' and `tramp-handle-file-directory-p'. (tramp-smb-handle-copy-directory, tramp-smb-handle-file-acl) (tramp-smb-handle-set-file-acl) (tramp-smb-maybe-open-connection): Do not set tramp-current-*. (tramp-smb-handle-file-directory-p): Remove. (tramp-smb-handle-make-symbolic-link): Use `tramp-get-connection-buffer' rather than `buffer-name'. * lisp/net/tramp.el (tramp-current-method, tramp-current-user) (tramp-current-domain, tramp-current-host) (tramp-current-port): Remove. (tramp-dissect-file-name): No special handling of localname anymore. (tramp-make-tramp-file-name): Reimplemnt with new signature. (tramp-completion-make-tramp-file-name): Fix docstring. (tramp-get-buffer, tramp-handle-file-name-as-directory) (tramp-handle-file-name-directory) (tramp-check-cached-permissions, tramp-local-host-p) (tramp-get-remote-tmpdir, tramp-clear-passwd): Adapt `tramp-make-tramp-file-name' call. (tramp-completion-handle-file-name-all-completions) (tramp-action-login, tramp-read-passwd): Do not set tramp-current-*. (tramp-handle-file-directory-p): New defun. (tramp-handle-verify-visited-file-modtime): Remove superfluous `with-parsed-tramp-file-name'. (tramp-process-actions, tramp-read-passwd): Use "password-vector" property. (tramp-call-process, tramp-call-process-region): No special setting of vec. (tramp-read-passwd): Handle "login-as" property. * test/lisp/net/tramp-tests.el (tramp-test21-file-links): Special code for "smb". diff --git a/doc/misc/trampver.texi b/doc/misc/trampver.texi index 5d9dcc5635..3122facc5e 100644 --- a/doc/misc/trampver.texi +++ b/doc/misc/trampver.texi @@ -8,7 +8,7 @@ @c In the Tramp GIT, the version number is auto-frobbed from @c configure.ac, so you should edit that file and run @c "autoconf && ./configure" to change the version number. -@set trampver 2.3.3-pre +@set trampver 2.4.0-pre @c Other flags from configuration @set instprefix /usr/local diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 8399c02923..f1753cec53 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -114,7 +114,7 @@ It is used for TCP/IP devices." (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . ignore) (file-attributes . tramp-adb-handle-file-attributes) - (file-directory-p . tramp-adb-handle-file-directory-p) + (file-directory-p . tramp-handle-file-directory-p) (file-equal-p . tramp-handle-file-equal-p) ;; FIXME: This is too sloppy. (file-executable-p . tramp-handle-file-exists-p) @@ -199,11 +199,13 @@ pass to the OPERATION." (with-temp-buffer ;; `call-process' does not react on timer under MS Windows. ;; That's why we use `start-process'. + ;; We don't know yet whether we need a user or host name for the + ;; connection vector. We assume we don't, it will be OK in most + ;; of the cases. Otherwise, there might be an additional trace + ;; buffer, which doesn't hurt. (let ((p (start-process tramp-adb-program (current-buffer) tramp-adb-program "devices")) - (v (make-tramp-file-name - :method tramp-adb-method :user tramp-current-user - :host tramp-current-host)) + (v (make-tramp-file-name :method tramp-adb-method)) result) (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " ")) (process-put p 'adjust-window-size-function 'ignore) @@ -245,16 +247,8 @@ pass to the OPERATION." ;; be problems with UNC shares or Cygwin mounts. (let ((default-directory (tramp-compat-temporary-file-directory))) (tramp-make-tramp-file-name - method user domain host port - (tramp-drop-volume-letter - (tramp-run-real-handler - 'expand-file-name (list localname)))))))) - -(defun tramp-adb-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - (eq (tramp-compat-file-attribute-type - (file-attributes (file-truename filename))) - t)) + v (tramp-drop-volume-letter + (tramp-run-real-handler 'expand-file-name (list localname)))))))) (defun tramp-adb-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." @@ -288,7 +282,7 @@ pass to the OPERATION." "%s%s" (with-parsed-tramp-file-name (expand-file-name filename) nil (tramp-make-tramp-file-name - method user domain host port + v (with-tramp-file-property v localname "file-truename" (let ((result nil)) ; result steps in reverse order (tramp-message v 4 "Finding true name for `%s'" filename) @@ -316,12 +310,10 @@ pass to the OPERATION." (tramp-compat-file-attribute-type (file-attributes (tramp-make-tramp-file-name - method user domain host port - (mapconcat 'identity - (append '("") - (reverse result) - (list thisstep)) - "/"))))) + v (mapconcat 'identity + (append + '("") (reverse result) (list thisstep)) + "/"))))) (cond ((string= "." thisstep) (tramp-message v 5 "Ignoring step `.'")) ((string= ".." thisstep) @@ -861,8 +853,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq input (with-parsed-tramp-file-name infile nil localname)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) - tmpinput (tramp-make-tramp-file-name - method user domain host port input)) + tmpinput (tramp-make-tramp-file-name v input)) (copy-file infile tmpinput t))) (when input (setq command (format "%s <%s" command input))) @@ -895,8 +886,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; stderr must be copied to remote host. The temporary ;; file must be deleted after execution. (setq stderr (tramp-make-tramp-temp-file v) - tmpstderr (tramp-make-tramp-file-name - method user domain host port stderr)))) + tmpstderr (tramp-make-tramp-file-name v stderr)))) ;; stderr to be discarded. ((null (cadr destination)) (setq stderr "/dev/null")))) @@ -1252,10 +1242,6 @@ connection if a previous connection has died for some reason." (user (tramp-file-name-user vec)) (device (tramp-adb-get-device vec))) - ;; Set variables for proper tracing in `tramp-adb-parse-device-names'. - (setq tramp-current-user (tramp-file-name-user vec) - tramp-current-host (tramp-file-name-host vec)) - ;; Maybe we know already that "su" is not supported. We cannot ;; use a connection property, because we have not checked yet ;; whether it is still the same device. diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index dc97501be3..87ec3c2a13 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -98,10 +98,7 @@ matching entries of `tramp-connection-properties'." (dolist (elt tramp-connection-properties) (when (string-match (or (nth 0 elt) "") - (tramp-make-tramp-file-name - (tramp-file-name-method key) (tramp-file-name-user key) - (tramp-file-name-domain key) (tramp-file-name-host key) - (tramp-file-name-port key) nil)) + (tramp-make-tramp-file-name key 'noloc 'nohop)) (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) hash))) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 37a6521680..35c00a0155 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -80,16 +80,7 @@ When called interactively, a Tramp connection has to be selected." ;; Return nil when there is no Tramp connection. (list (let ((connections - (mapcar - (lambda (x) - (tramp-make-tramp-file-name - (tramp-file-name-method x) - (tramp-file-name-user x) - (tramp-file-name-domain x) - (tramp-file-name-host x) - (tramp-file-name-port x) - (tramp-file-name-localname x))) - (tramp-list-connections))) + (mapcar 'tramp-make-tramp-file-name (tramp-list-connections))) name) (when connections diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 1d1b04b44f..d862e957ce 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -429,6 +429,7 @@ Every entry is a list (NAME ADDRESS).") ("gvfs-trash" . "trash")) "List of cons cells, mapping \"gvfs-\" to \"gio \".") +;; (defconst tramp-gvfs-file-attributes '("name" "type" @@ -495,7 +496,7 @@ Every entry is a list (NAME ADDRESS).") (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . ignore) (file-attributes . tramp-gvfs-handle-file-attributes) - (file-directory-p . tramp-gvfs-handle-file-directory-p) + (file-directory-p . tramp-handle-file-directory-p) (file-equal-p . tramp-handle-file-equal-p) (file-executable-p . tramp-gvfs-handle-file-executable-p) (file-exists-p . tramp-handle-file-exists-p) @@ -642,7 +643,7 @@ is no information where to trace the message.") (defun tramp-gvfs-dbus-event-error (event err) "Called when a D-Bus error message arrives, see `dbus-event-error-functions'." (when tramp-gvfs-dbus-event-vector - (tramp-message tramp-gvfs-dbus-event-vector 10 "%S" event) + (tramp-message tramp-gvfs-dbus-event-vector 6 "%S" event) (tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err)))) ;; `dbus-event-error-hooks' has been renamed to @@ -675,6 +676,7 @@ file names." (unless (memq op '(copy rename)) (error "Unknown operation `%s', must be `copy' or `rename'" op)) + (setq filename (file-truename filename)) (if (file-directory-p filename) (progn (copy-directory filename newname keep-date t) @@ -1043,11 +1045,6 @@ If FILE-SYSTEM is non-nil, return file system attributes." res-device ))))) -(defun tramp-gvfs-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - (eq t (tramp-compat-file-attribute-type - (file-attributes (file-truename filename))))) - (defun tramp-gvfs-handle-file-executable-p (filename) "Like `file-executable-p' for Tramp files." (with-parsed-tramp-file-name filename nil @@ -1363,13 +1360,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (unless (tramp-get-connection-property l "first-password-request" nil) (tramp-clear-passwd l)) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method l-method - tramp-current-user user - tramp-current-domain l-domain - tramp-current-host l-host - tramp-current-port l-port - password (tramp-read-passwd + (setq password (tramp-read-passwd (tramp-get-connection-process l) pw-prompt)) ;; Return result. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 14c1a4049a..1ca19e05f2 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2362,15 +2362,6 @@ The method used must be an out-of-band method." (expand-file-name ".." tmpfile) 'recursive) (delete-file tmpfile))))) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method (tramp-file-name-method v) - tramp-current-user (or (tramp-file-name-user v) - (tramp-get-connection-property - v "login-as" nil)) - tramp-current-domain (tramp-file-name-domain v) - tramp-current-host (tramp-file-name-host v) - tramp-current-port (tramp-file-name-port v)) - ;; Check which ones of source and target are Tramp files. (setq source (funcall (if (and (file-directory-p filename) @@ -2866,13 +2857,7 @@ the result will be a local, non-Tramp, file name." ;; We discard hops, if existing, that's why we cannot use ;; `file-remote-p'. (prompt (format "PS1=%s %s" - (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-domain v) - (tramp-file-name-host v) - (tramp-file-name-port v) - (tramp-file-name-localname v)) + (tramp-make-tramp-file-name v nil 'nohop) tramp-initial-end-of-output)) ;; We use as environment the difference to toplevel ;; `process-environment'. @@ -4755,8 +4740,7 @@ connection if a previous connection has died for some reason." (set-process-sentinel p 'tramp-process-sentinel) (process-put p 'adjust-window-size-function 'ignore) (set-process-query-on-exit-flag p nil) - (setq tramp-current-connection (cons vec (current-time)) - tramp-current-host (system-name)) + (setq tramp-current-connection (cons vec (current-time))) (tramp-message vec 6 "%s" (mapconcat 'identity (process-command p) " ")) @@ -4810,16 +4794,15 @@ connection if a previous connection has died for some reason." ;; Check, whether there is a restricted shell. (dolist (elt tramp-restricted-shell-hosts-alist) - (when (string-match elt tramp-current-host) + (when (string-match elt l-host) (setq r-shell t))) - ;; Set variables for computing the prompt for - ;; reading password. - (setq tramp-current-method l-method - tramp-current-user l-user - tramp-current-domain l-domain - tramp-current-host l-host - tramp-current-port l-port) + ;; Set password prompt vector. + (tramp-set-connection-property + p "password-vector" + (make-tramp-file-name + :method l-method :user l-user :domain l-domain + :host l-host :port l-port)) ;; Add login environment. (when login-env @@ -5244,14 +5227,7 @@ Nonexistent directories are removed from spec." (lambda (x) (and (stringp x) - (file-directory-p - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - x)) + (file-directory-p (tramp-make-tramp-file-name vec x)) x)) remote-path))))) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index a4d4b4e0bc..5a8299b1da 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -228,10 +228,10 @@ See `tramp-actions-before-shell' for more info.") (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (expand-file-name . tramp-smb-handle-expand-file-name) - (file-accessible-directory-p . tramp-smb-handle-file-directory-p) + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . tramp-smb-handle-file-acl) (file-attributes . tramp-smb-handle-file-attributes) - (file-directory-p . tramp-smb-handle-file-directory-p) + (file-directory-p . tramp-handle-file-directory-p) (file-file-equal-p . tramp-handle-file-equal-p) (file-executable-p . tramp-handle-file-exists-p) (file-exists-p . tramp-handle-file-exists-p) @@ -449,13 +449,6 @@ pass to the OPERATION." (if (not (file-directory-p newname)) (make-directory newname parents)) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - (let* ((share (tramp-smb-get-share v)) (localname (file-name-as-directory (replace-regexp-in-string @@ -739,62 +732,56 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (defun tramp-smb-handle-file-acl (filename) "Like `file-acl' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-tramp-file-property v localname "file-acl" - (when (executable-find tramp-smb-acl-program) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - - (let* ((share (tramp-smb-get-share v)) - (localname (replace-regexp-in-string - "\\\\" "/" (tramp-smb-get-localname v))) - (args (list (concat "//" host "/" share) "-E"))) - - (if (not (zerop (length user))) - (setq args (append args (list "-U" user))) - (setq args (append args (list "-N")))) - - (when domain (setq args (append args (list "-W" domain)))) - (when port (setq args (append args (list "-p" port)))) - (when tramp-smb-conf - (setq args (append args (list "-s" tramp-smb-conf)))) - (setq - args - (append args (list (tramp-unquote-shell-quote-argument localname) - "2>/dev/null"))) - - (unwind-protect - (with-temp-buffer - ;; Set the transfer process properties. - (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) - (tramp-set-connection-property - v "process-buffer" (current-buffer)) - - ;; Use an asynchronous processes. By this, password - ;; can be handled. - (let ((p (apply - 'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - tramp-smb-acl-program args))) - - (tramp-message - v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" v) - (process-put p 'adjust-window-size-function 'ignore) - (set-process-query-on-exit-flag p nil) - (tramp-process-actions p v nil tramp-smb-actions-get-acl) - (when (> (point-max) (point-min)) - (substring-no-properties (buffer-string))))) - - ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil))))))) + (ignore-errors + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-acl" + (when (executable-find tramp-smb-acl-program) + (let* ((share (tramp-smb-get-share v)) + (localname (replace-regexp-in-string + "\\\\" "/" (tramp-smb-get-localname v))) + (args (list (concat "//" host "/" share) "-E"))) + + (if (not (zerop (length user))) + (setq args (append args (list "-U" user))) + (setq args (append args (list "-N")))) + + (when domain (setq args (append args (list "-W" domain)))) + (when port (setq args (append args (list "-p" port)))) + (when tramp-smb-conf + (setq args (append args (list "-s" tramp-smb-conf)))) + (setq + args + (append args (list (tramp-unquote-shell-quote-argument localname) + "2>/dev/null"))) + + (unwind-protect + (with-temp-buffer + ;; Set the transfer process properties. + (tramp-set-connection-property + v "process-name" (buffer-name (current-buffer))) + (tramp-set-connection-property + v "process-buffer" (current-buffer)) + + ;; Use an asynchronous process. By this, password can + ;; be handled. + (let ((p (apply + 'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + tramp-smb-acl-program args))) + + (tramp-message + v 6 "%s" (mapconcat 'identity (process-command p) " ")) + (tramp-set-connection-property p "vector" v) + (process-put p 'adjust-window-size-function 'ignore) + (set-process-query-on-exit-flag p nil) + (tramp-process-actions p v nil tramp-smb-actions-get-acl) + (when (> (point-max) (point-min)) + (substring-no-properties (buffer-string))))) + + ;; Reset the transfer process properties. + (tramp-set-connection-property v "process-name" nil) + (tramp-set-connection-property v "process-buffer" nil)))))))) (defun tramp-smb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." @@ -911,13 +898,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (list id link uid gid atime mtime ctime size mode nil inode (tramp-get-device vec)))))))) -(defun tramp-smb-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - (and (file-exists-p filename) - (eq ?d - (aref (tramp-compat-file-attribute-modes (file-attributes filename)) - 0)))) - (defun tramp-smb-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name (file-truename filename) nil @@ -1222,7 +1202,7 @@ component is used as the target of the symlink." (tramp-error v 'file-error "error with make-symbolic-link, see buffer `%s' for details" - (buffer-name))))))) + (tramp-get-connection-buffer v))))))) (defun tramp-smb-handle-process-file (program &optional infile destination display &rest args) @@ -1403,15 +1383,9 @@ component is used as the target of the symlink." "Like `set-file-acl' for Tramp files." (ignore-errors (with-parsed-tramp-file-name filename nil - (when (and (stringp acl-string) (executable-find tramp-smb-acl-program)) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - (tramp-set-file-property v localname "file-acl" 'undef) + (tramp-set-file-property v localname "file-acl" 'undef) + (when (and (stringp acl-string) (executable-find tramp-smb-acl-program)) (let* ((share (tramp-smb-get-share v)) (localname (replace-regexp-in-string "\\\\" "/" (tramp-smb-get-localname v))) @@ -1971,13 +1945,6 @@ If ARGUMENT is non-nil, use it as argument for (process-put p 'adjust-window-size-function 'ignore) (set-process-query-on-exit-flag p nil) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method tramp-smb-method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - (condition-case err (let (tramp-message-show-message) ;; Play login scenario. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 2fdc651a37..b933778447 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1182,21 +1182,6 @@ means to use always cached values for the directory contents." ;;; Internal Variables: -(defvar tramp-current-method nil - "Connection method for this *tramp* buffer.") - -(defvar tramp-current-user nil - "Remote login name for this *tramp* buffer.") - -(defvar tramp-current-domain nil - "Remote domain name for this *tramp* buffer.") - -(defvar tramp-current-host nil - "Remote host for this *tramp* buffer.") - -(defvar tramp-current-port nil - "Remote port for this *tramp* buffer.") - (defvar tramp-current-connection nil "Last connection timestamp.") @@ -1390,7 +1375,7 @@ values." (make-tramp-file-name :method method :user user :domain domain :host host :port port - :localname (or localname "") :hop hop))))) + :localname localname :hop hop))))) (defun tramp-buffer-name (vec) "A name for the connection buffer VEC." @@ -1401,30 +1386,64 @@ values." (format "*tramp/%s %s@%s*" method user-domain host-port) (format "*tramp/%s %s*" method host-port)))) -(defun tramp-make-tramp-file-name - (method user domain host port localname &optional hop) - "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME. -When not nil, optional DOMAIN, PORT and HOP are used." - (concat tramp-prefix-format hop - (unless (or (zerop (length method)) - (zerop (length tramp-postfix-method-format))) - (concat method tramp-postfix-method-format)) - user - (unless (zerop (length domain)) - (concat tramp-prefix-domain-format domain)) - (unless (zerop (length user)) - tramp-postfix-user-format) - (when host - (if (string-match tramp-ipv6-regexp host) - (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) - host)) - (unless (zerop (length port)) - (concat tramp-prefix-port-format port)) - tramp-postfix-host-format - (when localname localname))) +(defun tramp-make-tramp-file-name (&rest args) + "Construct a Tramp file name from ARGS. + +ARGS could have two different signatures. The first one is of +type (VEC &optional LOCALNAME HOP). +If LOCALNAME is nil, the value in VEC is used. If it is a +symbol, a null localname will be used. Otherwise, LOCALNAME is +expected to be a string, which will be used. +If HOP is nil, the value in VEC is used. If it is a symbol, a +null hop will be used. Otherwise, HOP is expected to be a +string, which will be used. + +The other signature exists for backward compatibility. It has +the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." + (let (method user domain host port localname hop) + (cond + ((tramp-file-name-p (car args)) + (setq method (tramp-file-name-method (car args)) + user (tramp-file-name-user (car args)) + domain (tramp-file-name-domain (car args)) + host (tramp-file-name-host (car args)) + port (tramp-file-name-port (car args)) + localname (tramp-file-name-localname (car args)) + hop (tramp-file-name-hop (car args))) + (when (cadr args) + (setq localname (and (stringp (cadr args)) (cadr args)))) + (when (cl-caddr args) + (setq hop (and (stringp (cl-caddr args)) (cl-caddr args))))) + + (t (setq method (nth 0 args) + user (nth 1 args) + domain (nth 2 args) + host (nth 3 args) + port (nth 4 args) + localname (nth 5 args) + hop (nth 6 args)))) + + (concat tramp-prefix-format hop + (unless (or (zerop (length method)) + (zerop (length tramp-postfix-method-format))) + (concat method tramp-postfix-method-format)) + user + (unless (zerop (length domain)) + (concat tramp-prefix-domain-format domain)) + (unless (zerop (length user)) + tramp-postfix-user-format) + (when host + (if (string-match tramp-ipv6-regexp host) + (concat + tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) + host)) + (unless (zerop (length port)) + (concat tramp-prefix-port-format port)) + tramp-postfix-host-format + localname))) (defun tramp-completion-make-tramp-file-name (method user host localname) - "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME. + "Construct a Tramp file name from METHOD, USER, HOST and LOCALNAME. It must not be a complete Tramp file name, but as long as there are necessary only. This function will be used in file name completion." (concat tramp-prefix-format @@ -1451,15 +1470,8 @@ necessary only. This function will be used in file name completion." (tramp-set-connection-property vec "process-buffer" (tramp-get-connection-property vec "process-buffer" nil)) - (setq buffer-undo-list t) - (setq default-directory - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - "/")) + (setq buffer-undo-list t + default-directory (tramp-make-tramp-file-name vec "/" 'nohop)) (current-buffer)))) (defun tramp-get-connection-buffer (vec) @@ -2352,7 +2364,9 @@ remote file names." (defun tramp-register-file-name-handlers () "Add Tramp file name handlers to `file-name-handler-alist'." ;; Remove autoloaded handlers from file name handler alist. Useful, - ;; if `tramp-syntax' has been changed. + ;; if `tramp-syntax' has been changed. We cannot call + ;; `tramp-unload-file-name-handlers', this would result in recursive + ;; loading of Tramp. (dolist (fnh '(tramp-file-name-handler tramp-completion-file-name-handler tramp-autoload-file-name-handler)) @@ -2488,7 +2502,6 @@ not in completion mode." (host (tramp-file-name-host elt)) (localname (tramp-file-name-localname elt)) (m (tramp-find-method method user host)) - (tramp-current-user user) ; see `tramp-parse-passwd' all-user-hosts) (unless localname ;; Nothing to complete. @@ -2978,6 +2991,12 @@ User is always nil." (and (file-directory-p filename) (file-readable-p filename))) +(defun tramp-handle-file-directory-p (filename) + "Like `file-directory-p' for Tramp files." + (eq (tramp-compat-file-attribute-type + (file-attributes (file-truename filename))) + t)) + (defun tramp-handle-file-equal-p (filename1 filename2) "Like `file-equalp-p' for Tramp files." ;; Native `file-equalp-p' calls `file-truename', which requires a @@ -3018,17 +3037,11 @@ User is always nil." ;; Run the command on the localname portion only unless we are in ;; completion mode. (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-domain v) - (tramp-file-name-host v) - (tramp-file-name-port v) - (if (and (zerop (length (tramp-file-name-localname v))) - (not (tramp-connectable-p file))) - "" - (tramp-run-real-handler - 'file-name-as-directory (list (or (tramp-file-name-localname v) "")))) - (tramp-file-name-hop v)))) + v (unless (and (zerop (length (tramp-file-name-localname v))) + (not (tramp-connectable-p file))) + (tramp-run-real-handler + 'file-name-as-directory + (list (or (tramp-file-name-localname v) ""))))))) (defun tramp-handle-file-name-case-insensitive-p (filename) "Like `file-name-case-insensitive-p' for Tramp files." @@ -3116,14 +3129,8 @@ User is always nil." (let ((v (tramp-dissect-file-name file t))) ;; Run the command on the localname portion only. (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-domain v) - (tramp-file-name-host v) - (tramp-file-name-port v) - (tramp-run-real-handler - 'file-name-directory (list (or (tramp-file-name-localname v) ""))) - (tramp-file-name-hop v)))) + v (tramp-run-real-handler + 'file-name-directory (list (or (tramp-file-name-localname v) "")))))) (defun tramp-handle-file-name-nondirectory (file) "Like `file-name-nondirectory' but aware of Tramp files." @@ -3162,7 +3169,8 @@ User is always nil." (and (or (not connected) c) (cond ((eq identification 'method) method) - ;; Domain and port are appended. + ;; Domain and port are appended to user and host, + ;; respectively. ((eq identification 'user) (tramp-file-name-user-domain v)) ((eq identification 'host) (tramp-file-name-host-port v)) ((eq identification 'localname) localname) @@ -3574,29 +3582,28 @@ of." (eq (visited-file-modtime) 0) (not (file-remote-p f nil 'connected))) t - (with-parsed-tramp-file-name f nil - (let* ((remote-file-name-inhibit-cache t) - (attr (file-attributes f)) - (modtime (tramp-compat-file-attribute-modification-time attr)) - (mt (visited-file-modtime))) - - (cond - ;; File exists, and has a known modtime. - ((and attr (not (equal modtime '(0 0)))) - (< (abs (tramp-time-diff - modtime - ;; For compatibility, deal with both the old - ;; (HIGH . LOW) and the new (HIGH LOW) return - ;; values of `visited-file-modtime'. - (if (atom (cdr mt)) - (list (car mt) (cdr mt)) - mt))) - 2)) - ;; Modtime has the don't know value. - (attr t) - ;; If file does not exist, say it is not modified if and - ;; only if that agrees with the buffer's record. - (t (equal mt '(-1 65535)))))))))) + (let* ((remote-file-name-inhibit-cache t) + (attr (file-attributes f)) + (modtime (tramp-compat-file-attribute-modification-time attr)) + (mt (visited-file-modtime))) + + (cond + ;; File exists, and has a known modtime. + ((and attr (not (equal modtime '(0 0)))) + (< (abs (tramp-time-diff + modtime + ;; For compatibility, deal with both the old + ;; (HIGH . LOW) and the new (HIGH LOW) return + ;; values of `visited-file-modtime'. + (if (atom (cdr mt)) + (list (car mt) (cdr mt)) + mt))) + 2)) + ;; Modtime has the don't know value. + (attr t) + ;; If file does not exist, say it is not modified if and + ;; only if that agrees with the buffer's record. + (t (equal mt '(-1 65535))))))))) (defun tramp-handle-file-notify-add-watch (filename _flags _callback) "Like `file-notify-add-watch' for Tramp files." @@ -3633,17 +3640,16 @@ of." (defun tramp-action-login (_proc vec) "Send the login name." - (when (not (stringp tramp-current-user)) - (setq tramp-current-user - (with-tramp-connection-property vec "login-as" - (save-window-excursion - (let ((enable-recursive-minibuffers t)) - (pop-to-buffer (tramp-get-connection-buffer vec)) - (read-string (match-string 0))))))) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) - (tramp-message vec 3 "Sending login name `%s'" tramp-current-user) - (tramp-send-string vec (concat tramp-current-user tramp-local-end-of-line))) + (let ((user (or (tramp-file-name-user vec) + (with-tramp-connection-property vec "login-as" + (save-window-excursion + (let ((enable-recursive-minibuffers t)) + (pop-to-buffer (tramp-get-connection-buffer vec)) + (read-string (match-string 0)))))))) + (with-current-buffer (tramp-get-connection-buffer vec) + (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message vec 3 "Sending login name `%s'" user) + (tramp-send-string vec (concat user tramp-local-end-of-line)))) (defun tramp-action-password (proc vec) "Query the user for a password." @@ -3767,12 +3773,11 @@ PROC and VEC indicate the remote connection to be used. POS, if set, is the starting point of the region to be deleted in the connection buffer." ;; Enable `auth-source', unless "emacs -Q" has been called. We must - ;; use `tramp-current-*' variables in case we have several hops. + ;; use the "password-vector" property in case we have several hops. (tramp-set-connection-property - (make-tramp-file-name - :method tramp-current-method :user tramp-current-user - :domain tramp-current-domain :host tramp-current-host - :port tramp-current-port) + (tramp-get-connection-property + proc "password-vector" + (tramp-get-connection-property proc "vector" nil)) "first-password-request" tramp-cache-read-persistent-data) (save-restriction (with-tramp-progress-reporter @@ -4140,15 +4145,7 @@ be granted." vec (tramp-file-name-localname vec) (concat "file-attributes-" suffix) nil) (file-attributes - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - (tramp-file-name-localname vec) - (tramp-file-name-hop vec)) - (intern suffix)))) + (tramp-make-tramp-file-name vec) (intern suffix)))) (remote-uid (tramp-get-connection-property vec (concat "uid-" suffix) nil)) @@ -4205,11 +4202,7 @@ be granted." ;; The local temp directory must be writable for the other user. (file-writable-p (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - host port - (tramp-compat-temporary-file-directory))) + vec (tramp-compat-temporary-file-directory) 'nohop)) ;; On some systems, chown runs only for root. (or (zerop (user-uid)) ;; This is defined in tramp-sh.el. Let's assume this is @@ -4219,14 +4212,9 @@ be granted." (defun tramp-get-remote-tmpdir (vec) "Return directory for temporary files on the remote host identified by VEC." (with-tramp-connection-property vec "tmpdir" - (let ((dir (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp") - (tramp-file-name-hop vec)))) + (let ((dir + (tramp-make-tramp-file-name + vec (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp")))) (or (and (file-directory-p dir) (file-writable-p dir) (file-remote-p dir 'localname)) (tramp-error vec 'file-error "Directory %s not accessible" dir)) @@ -4339,15 +4327,10 @@ It always returns a return code. The Lisp error raised when PROGRAM is nil is trapped also, returning 1. Furthermore, traces are written with verbosity of 6." (let ((default-directory (tramp-compat-temporary-file-directory)) - (v (or vec - (make-tramp-file-name - :method tramp-current-method :user tramp-current-user - :domain tramp-current-domain :host tramp-current-host - :port tramp-current-port))) (destination (if (eq destination t) (current-buffer) destination)) output error result) (tramp-message - v 6 "`%s %s' %s %s" + vec 6 "`%s %s' %s %s" program (mapconcat 'identity args " ") infile destination) (condition-case err (with-temp-buffer @@ -4365,8 +4348,8 @@ are written with verbosity of 6." (setq error (error-message-string err) result 1))) (if (zerop (length error)) - (tramp-message v 6 "%d\n%s" result output) - (tramp-message v 6 "%d\n%s\n%s" result output error)) + (tramp-message vec 6 "%d\n%s" result output) + (tramp-message vec 6 "%d\n%s\n%s" result output error)) result)) (defun tramp-call-process-region @@ -4376,15 +4359,10 @@ It always returns a return code. The Lisp error raised when PROGRAM is nil is trapped also, returning 1. Furthermore, traces are written with verbosity of 6." (let ((default-directory (tramp-compat-temporary-file-directory)) - (v (or vec - (make-tramp-file-name - :method tramp-current-method :user tramp-current-user - :domain tramp-current-domain :host tramp-current-host - :port tramp-current-port))) (buffer (if (eq buffer t) (current-buffer) buffer)) result) (tramp-message - v 6 "`%s %s' %s %s %s %s" + vec 6 "`%s %s' %s %s %s %s" program (mapconcat 'identity args " ") start end delete buffer) (condition-case err (progn @@ -4397,11 +4375,11 @@ are written with verbosity of 6." (signal 'file-error (list result))) (with-current-buffer (if (bufferp buffer) buffer (current-buffer)) (if (zerop result) - (tramp-message v 6 "%d" result) - (tramp-message v 6 "%d\n%s" result (buffer-string))))) + (tramp-message vec 6 "%d" result) + (tramp-message vec 6 "%d\n%s" result (buffer-string))))) (error (setq result 1) - (tramp-message v 6 "%d\n%s" result (error-message-string err)))) + (tramp-message vec 6 "%d\n%s" result (error-message-string err)))) result)) ;;;###tramp-autoload @@ -4411,8 +4389,13 @@ Consults the auth-source package. Invokes `password-read' if available, `read-passwd' else." (let* ((case-fold-search t) (key (tramp-make-tramp-file-name - tramp-current-method tramp-current-user tramp-current-domain - tramp-current-host tramp-current-port "")) + ;; In tramp-sh.el, we must use "password-vector" due to + ;; multi-hop. + (tramp-get-connection-property + proc "password-vector" + ;; All other backends simply use "vector". + (tramp-get-connection-property proc "vector" nil)) + 'noloc 'nohop)) (pw-prompt (or prompt (with-current-buffer (process-buffer proc) @@ -4424,6 +4407,8 @@ Invokes `password-read' if available, `read-passwd' else." (unwind-protect (with-parsed-tramp-file-name key nil + (setq user + (or user (tramp-get-connection-property key "login-as" nil))) (prog1 (or ;; See if auth-sources contains something useful. @@ -4434,24 +4419,16 @@ Invokes `password-read' if available, `read-passwd' else." (setq auth-info (auth-source-search :max 1 - (and tramp-current-user :user) - (if tramp-current-domain - (format - "%s%s%s" - tramp-current-user tramp-prefix-domain-format - tramp-current-domain) - tramp-current-user) + (and user :user) + (if domain + (concat user tramp-prefix-domain-format domain) + user) :host - (if tramp-current-port - (format - "%s%s%s" - tramp-current-host tramp-prefix-port-format - tramp-current-port) - tramp-current-host) - :port tramp-current-method - :require - (cons - :secret (and tramp-current-user '(:user)))) + (if port + (concat host tramp-prefix-port-format port) + host) + :port method + :require (cons :secret (and user '(:user)))) auth-passwd (plist-get (nth 0 auth-info) :secret) auth-passwd (if (functionp auth-passwd) @@ -4471,11 +4448,7 @@ Invokes `password-read' if available, `read-passwd' else." (defun tramp-clear-passwd (vec) "Clear password cache for connection related to VEC." (let ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (domain (tramp-file-name-domain vec)) (user-domain (tramp-file-name-user-domain vec)) - (host (tramp-file-name-host vec)) - (port (tramp-file-name-port vec)) (host-port (tramp-file-name-host-port vec)) (hop (tramp-file-name-hop vec))) (when hop @@ -4490,8 +4463,7 @@ Invokes `password-read' if available, `read-passwd' else." (auth-source-forget `(:max 1 ,(and user-domain :user) ,user-domain :host ,host-port :port ,method)) - (password-cache-remove - (tramp-make-tramp-file-name method user domain host port "")))) + (password-cache-remove (tramp-make-tramp-file-name vec 'noloc 'nohop)))) ;; Snarfed code from time-date.el. diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 51af455e63..4506698c36 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -7,7 +7,7 @@ ;; Maintainer: Michael Albinus ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.3.3-pre +;; Version: 2.4.0-pre ;; This file is part of GNU Emacs. @@ -33,7 +33,7 @@ ;; should be changed only there. ;;;###tramp-autoload -(defconst tramp-version "2.3.3-pre" +(defconst tramp-version "2.4.0-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -55,7 +55,7 @@ ;; Check for Emacs version. (let ((x (if (>= emacs-major-version 24) "ok" - (format "Tramp 2.3.3-pre is not fit for %s" + (format "Tramp 2.4.0-pre is not fit for %s" (when (string-match "^.*$" (emacs-version)) (match-string 0 (emacs-version))))))) (unless (string-match "\\`ok\\'" x) (error "%s" x))) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index a9d6e74ce2..5fb3162769 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2877,9 +2877,15 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (tramp--test-ignore-make-symbolic-link-error (make-symbolic-link tmp-name2 tmp-name1) (should (file-symlink-p tmp-name1)) - (make-symbolic-link tmp-name1 tmp-name2) - (should (file-symlink-p tmp-name2)) - (should-error (file-truename tmp-name1) :type 'file-error)) + (if (tramp-smb-file-name-p tramp-test-temporary-file-directory) + ;; The symlink command of `smbclient' detects the + ;; cycle already. + (should-error + (make-symbolic-link tmp-name1 tmp-name2) + :type 'file-error) + (make-symbolic-link tmp-name1 tmp-name2) + (should (file-symlink-p tmp-name2)) + (should-error (file-truename tmp-name1) :type 'file-error))) ;; Cleanup. (ignore-errors commit b067fa1f7d2b24b8fdb7f178924eb4e296559738 Author: Michael Albinus Date: Fri Dec 8 16:37:53 2017 +0100 Minor Tramp fixes * lisp/net/tramp-gvfs.el (tramp-gvfs-do-copy-or-rename-file): Fix a bug when renaming. * test/lisp/net/tramp-tests.el (tramp-test21-file-links): Extend test. (tramp-test42-delay-load, tramp-test42-remote-load-path): Skip unless Emacs >= 26. diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index fe5a98909e..1d1b04b44f 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -683,7 +683,6 @@ file names." (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname)) (equal-remote (tramp-equal-remote filename newname)) - (file-operation (intern (format "%s-file" op))) (gvfs-operation (if (eq op 'copy) "gvfs-copy" "gvfs-move")) (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) @@ -698,9 +697,11 @@ file names." ;; We cannot copy or rename directly. (let ((tmpfile (tramp-compat-make-temp-file filename))) - (funcall - file-operation filename tmpfile t keep-date preserve-uid-gid - preserve-extended-attributes) + (if (eq op 'copy) + (copy-file + filename tmpfile t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file filename tmpfile t)) (rename-file tmpfile newname ok-if-already-exists)) ;; Direct action. diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 0d1e7d18d9..a9d6e74ce2 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2810,7 +2810,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Symbolic links could look like a remote file name. ;; They must be quoted then. (delete-file tmp-name2) - (make-symbolic-link "/penguin:motd:" tmp-name2) + (make-symbolic-link + (funcall + (if quoted 'tramp-compat-file-name-unquote 'identity) + "/penguin:motd:") + tmp-name2) (should (file-symlink-p tmp-name2)) (should (string-equal @@ -4642,6 +4646,10 @@ process sentinels. They shall not disturb each other." (ert-deftest tramp-test42-delay-load () "Check that Tramp is loaded lazily, only when needed." + ;; The autoloaded Tramp objects are different since Emacs 26.1. We + ;; cannot test older Emacsen, therefore. + (skip-unless (tramp--test-emacs26-p)) + ;; Tramp is neither loaded at Emacs startup, nor when completing a ;; non-Tramp file name like "/foo". Completing a Tramp-alike file ;; name like "/foo:" autoloads Tramp, when `tramp-mode' is t. @@ -4654,8 +4662,8 @@ process sentinels. They shall not disturb each other." (message \"Tramp loaded: %%s\" (featurep 'tramp)) \ (file-name-all-completions \"/foo:\" \"/\") \ (message \"Tramp loaded: %%s\" (featurep 'tramp)))")) - ;; Tramp doesn't load when `tramp-mode' is nil since Emacs 26.1. - (dolist (tm (if (tramp--test-emacs26-p) '(t nil) '(nil))) + ;; Tramp doesn't load when `tramp-mode' is nil. + (dolist (tm '(t nil)) (should (string-match (format @@ -4693,6 +4701,10 @@ process sentinels. They shall not disturb each other." (ert-deftest tramp-test42-remote-load-path () "Check that Tramp autoloads its packages with remote `load-path'." + ;; The autoloaded Tramp objects are different since Emacs 26.1. We + ;; cannot test older Emacsen, therefore. + (skip-unless (tramp--test-emacs26-p)) + ;; `tramp-cleanup-all-connections' is autoloaded from tramp-cmds.el. ;; It shall still work, when a remote file name is in the ;; `load-path'. @@ -4770,6 +4782,8 @@ Since it unloads Tramp, it shall be the last test to run." ;; * dired-compress-file ;; * dired-uncache +;; * file-equal-p (partly done in `tramp-test21-file-links') +;; * file-in-directory-p ;; * file-name-case-insensitive-p ;; * Work on skipped tests. Make a comment, when it is impossible. commit 6c1a31e43c76ed5c08a4c5bbf2afe4ddc64e9a65 Author: Glenn Morris Date: Thu Dec 7 20:30:39 2017 -0500 * lisp/help-mode.el (help-function-def): Allow help-make-xrefs to call with one argument. (Bug#29611) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index a98bce0138..8bafa46aa9 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -192,20 +192,24 @@ The format is (FUNCTION ARGS...).") (define-button-type 'help-function-def :supertype 'help-xref - 'help-function (lambda (fun file &optional type) - (require 'find-func) - (when (eq file 'C-source) - (setq file - (help-C-file-name (indirect-function fun) 'fun))) - ;; Don't use find-function-noselect because it follows - ;; aliases (which fails for built-in functions). - (let ((location - (find-function-search-for-symbol fun type file))) - (pop-to-buffer (car location)) - (run-hooks 'find-function-after-hook) - (if (cdr location) - (goto-char (cdr location)) - (message "Unable to find location in file")))) + 'help-function (lambda (fun &optional file type) + (or file + (setq file (find-lisp-object-file-name fun type))) + (if (not file) + (message "Unable to find defining file") + (require 'find-func) + (when (eq file 'C-source) + (setq file + (help-C-file-name (indirect-function fun) 'fun))) + ;; Don't use find-function-noselect because it follows + ;; aliases (which fails for built-in functions). + (let ((location + (find-function-search-for-symbol fun type file))) + (pop-to-buffer (car location)) + (run-hooks 'find-function-after-hook) + (if (cdr location) + (goto-char (cdr location)) + (message "Unable to find location in file"))))) 'help-echo (purecopy "mouse-2, RET: find function's definition")) (define-button-type 'help-function-cmacro ; FIXME: Obsolete since 24.4. @@ -495,12 +499,6 @@ that." (help-xref-button 8 'help-face sym))) ((match-string 6)) ; nothing for `symbol' ((match-string 7) - ;; this used: - ;; #'(lambda (arg) - ;; (let ((location - ;; (find-function-noselect arg))) - ;; (pop-to-buffer (car location)) - ;; (goto-char (cdr location)))) (help-xref-button 8 'help-function-def sym)) ((cl-some (lambda (x) (funcall (nth 1 x) sym)) describe-symbol-backends) commit a4a97b06168e71dc0543f253aefea0e6de7d706e Author: Martin Rudalics Date: Thu Dec 7 09:55:21 2017 +0100 Fix doc-string of 'display-buffer-in-side-window' * lisp/window.el (display-buffer-in-side-window): In doc-string clarify why the window returned gets dedicated to its buffer. diff --git a/lisp/window.el b/lisp/window.el index b7736d85cd..c4572106f4 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -1008,8 +1008,9 @@ do not permit making a new window, a suitable existing window may be reused and have its `window-slot' parameter value accordingly modified. -Unless `display-buffer-mark-dedicated' is non-nil, softly -dedicate the side window used to BUFFER. Return the window used +Unless `display-buffer-mark-dedicated' is non-nil, dedicate the +side window used to BUFFER so that it does not get reused by +other `display-buffer' action functions. Return the window used for displaying BUFFER, nil if no suitable window can be found. This function installs the `window-side' and `window-slot' commit 9d9cbafce2d8ca00f61cc276d8a2a08c8211e82d Author: Michael Albinus Date: Wed Dec 6 20:49:30 2017 +0100 Fix Bug#29579 * lisp/files.el (file-name-non-special): Inhibit `file-name-handler-alist' only for some operations. Add missing operations. (Bug#29579) * lisp/net/tramp-compat.el (tramp-compat-file-name-quote): Do not quote if it is quoted already. * lisp/net/tramp-smb.el (tramp-smb-handle-insert-directory): Use `copy-tree' but `copy-sequence'. * lisp/net/tramp.el (tramp-handle-file-truename): Handle several trailing slashes correctly. * test/lisp/net/tramp-tests.el (tramp-test11-copy-file) (tramp-test12-rename-file, tramp-test24-file-acl) (tramp-test25-file-selinux, tramp--test-check-files): Handle also quoted file names. (tramp-test21-file-links): Fix file name quoting test. (tramp-test24-file-acl): Be more robust for "smb" method. (tramp-test35-make-auto-save-file-name): Enable hidden test cases. diff --git a/lisp/files.el b/lisp/files.el index a7ad40b76c..8045ba5c22 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -6956,60 +6956,67 @@ only these files will be asked to be saved." ;; We depend on being the last handler on the list, ;; so that anything else which does need handling ;; has been handled already. -;; So it is safe for us to inhibit *all* magic file name handlers. +;; So it is safe for us to inhibit *all* magic file name handlers for +;; operations, which return a file name. See Bug#29579. (defun file-name-non-special (operation &rest arguments) - (let ((file-name-handler-alist nil) - (default-directory - ;; Some operations respect file name handlers in - ;; `default-directory'. Because core function like - ;; `call-process' don't care about file name handlers in - ;; `default-directory', we here have to resolve the - ;; directory into a local one. For `process-file', - ;; `start-file-process', and `shell-command', this fixes - ;; Bug#25949. - (if (memq operation '(insert-directory process-file start-file-process - shell-command)) - (directory-file-name - (expand-file-name - (unhandled-file-name-directory default-directory))) - default-directory)) - ;; Get a list of the indices of the args which are file names. - (file-arg-indices - (cdr (or (assq operation - ;; The first six are special because they - ;; return a file name. We want to include the /: - ;; in the return value. - ;; So just avoid stripping it in the first place. - '((expand-file-name . nil) - (file-name-directory . nil) - (file-name-as-directory . nil) - (directory-file-name . nil) - (file-name-sans-versions . nil) - (find-backup-file-name . nil) - ;; `identity' means just return the first arg - ;; not stripped of its quoting. - (substitute-in-file-name identity) - ;; `add' means add "/:" to the result. - (file-truename add 0) - (insert-file-contents insert-file-contents 0) - ;; `unquote-then-quote' means set buffer-file-name - ;; temporarily to unquoted filename. - (verify-visited-file-modtime unquote-then-quote) - ;; List the arguments which are filenames. - (file-name-completion 1) - (file-name-all-completions 1) - (write-region 2 5) - (rename-file 0 1) - (copy-file 0 1) - (make-symbolic-link 0 1) - (add-name-to-file 0 1))) - ;; For all other operations, treat the first argument only - ;; as the file name. - '(nil 0)))) - method - ;; Copy ARGUMENTS so we can replace elements in it. - (arguments (copy-sequence arguments))) + (let* ((op-returns-file-name-list + '(expand-file-name file-name-directory file-name-as-directory + directory-file-name file-name-sans-versions + find-backup-file-name file-remote-p)) + (file-name-handler-alist + (and + (not (memq operation op-returns-file-name-list)) + file-name-handler-alist)) + (default-directory + ;; Some operations respect file name handlers in + ;; `default-directory'. Because core function like + ;; `call-process' don't care about file name handlers in + ;; `default-directory', we here have to resolve the + ;; directory into a local one. For `process-file', + ;; `start-file-process', and `shell-command', this fixes + ;; Bug#25949. + (if (memq operation + '(insert-directory process-file start-file-process + shell-command)) + (directory-file-name + (expand-file-name + (unhandled-file-name-directory default-directory))) + default-directory)) + ;; Get a list of the indices of the args which are file names. + (file-arg-indices + (cdr (or (assq operation + ;; The first seven are special because they + ;; return a file name. We want to include the /: + ;; in the return value. + ;; So just avoid stripping it in the first place. + (append + (mapcar 'list op-returns-file-name-list) + '(;; `identity' means just return the first arg + ;; not stripped of its quoting. + (substitute-in-file-name identity) + ;; `add' means add "/:" to the result. + (file-truename add 0) + (insert-file-contents insert-file-contents 0) + ;; `unquote-then-quote' means set buffer-file-name + ;; temporarily to unquoted filename. + (verify-visited-file-modtime unquote-then-quote) + ;; List the arguments which are filenames. + (file-name-completion 1) + (file-name-all-completions 1) + (write-region 2 5) + (rename-file 0 1) + (copy-file 0 1) + (copy-directory 0 1) + (file-in-directory-p 0 1) + (make-symbolic-link 0 1) + (add-name-to-file 0 1)))) + ;; For all other operations, treat the first argument only + ;; as the file name. + '(nil 0)))) + method + ;; Copy ARGUMENTS so we can replace elements in it. + (arguments (copy-sequence arguments))) (if (symbolp (car file-arg-indices)) (setq method (pop file-arg-indices))) ;; Strip off the /: from the file names that have it. diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 9326f7b186..9cdfc06512 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -210,8 +210,10 @@ If NAME is a remote file name, check the local part of NAME." (defsubst tramp-compat-file-name-quote (name) "Add the quotation prefix \"/:\" to file NAME. If NAME is a remote file name, the local part of NAME is quoted." - (concat - (file-remote-p name) "/:" (or (file-remote-p name 'localname) name)))) + (if (tramp-compat-file-name-quoted-p name) + name + (concat + (file-remote-p name) "/:" (or (file-remote-p name 'localname) name))))) (if (fboundp 'file-name-unquote) (defalias 'tramp-compat-file-name-unquote 'file-name-unquote) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index acb5a12ba2..14c1a4049a 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1036,6 +1036,7 @@ of command line.") (load . tramp-handle-load) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-sh-handle-make-directory) + ;; `make-directory-internal' performed by default handler. (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-symbolic-link . tramp-sh-handle-make-symbolic-link) (process-file . tramp-sh-handle-process-file) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index eb0d6b5073..a4d4b4e0bc 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -437,7 +437,7 @@ pass to the OPERATION." (delete-directory tmpdir 'recursive)))) ;; We can copy recursively. - ;; Does not work reliably. + ;; TODO: Does not work reliably. (nil ;(and (or t1 t2) (tramp-smb-get-cifs-capabilities v)) (when (and (file-directory-p newname) (not (string-equal (file-name-nondirectory dirname) @@ -1015,7 +1015,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (save-match-data (let ((base (file-name-nondirectory filename)) ;; We should not destroy the cache entry. - (entries (copy-sequence + (entries (copy-tree (tramp-smb-get-file-entries (file-name-directory filename)))) (avail (get-free-disk-space filename)) @@ -1441,7 +1441,7 @@ component is used as the target of the symlink." (tramp-set-connection-property v "process-buffer" (current-buffer)) - ;; Use an asynchronous processes. By this, password can + ;; Use an asynchronous process. By this, password can ;; be handled. (let ((p (apply 'start-process @@ -1456,6 +1456,9 @@ component is used as the target of the symlink." (set-process-query-on-exit-flag p nil) (tramp-process-actions p v nil tramp-smb-actions-set-acl) (goto-char (point-max)) + ;; This is meant for traces, and returning from the + ;; function. No error is propagated outside, due to + ;; the `ignore-errors' closure. (unless (re-search-backward "tramp_exit_status [0-9]+" nil t) (tramp-error v 'file-error diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 433baed6ed..2fdc651a37 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3217,7 +3217,7 @@ User is always nil." (tramp-error v1 'file-error "Maximum number (%d) of symlinks exceeded" numchase-limit))) - result)) + (directory-file-name result))) ;; Preserve trailing "/". (if (string-equal (file-name-nondirectory filename) "") "/" "")))) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 5699ab4b23..0d1e7d18d9 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -1882,9 +1882,9 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `copy-file'." (skip-unless (tramp--test-enabled)) - ;; TODO: The quoted case does not work. Copy local file to remote. - ;;(dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) - (let (quoted) + ;; `filename-non-special' has been fixed in Emacs 26.1, see Bug#29579. + (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs26-p)) + '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -1984,9 +1984,9 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `rename-file'." (skip-unless (tramp--test-enabled)) - ;; TODO: The quoted case does not work. - ;;(dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) - (let (quoted) + ;; `filename-non-special' has been fixed in Emacs 26.1, see Bug#29579. + (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs26-p)) + '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -2825,7 +2825,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; We must unquote it. (should (string-equal - (file-truename tmp-name1) + (tramp-compat-file-name-unquote (file-truename tmp-name1)) (tramp-compat-file-name-unquote (file-truename tmp-name3))))) ;; Cleanup. @@ -2951,9 +2951,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (tramp--test-enabled)) (skip-unless (file-acl tramp-test-temporary-file-directory)) - ;; TODO: The quoted case does not work. Copy local file to remote. - ;;(dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) - (let (quoted) + ;; `filename-non-special' has been fixed in Emacs 26.1, see Bug#29579. + (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs26-p)) + '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -2968,13 +2968,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (file-acl tmp-name2)) (should (string-equal (file-acl tmp-name1) (file-acl tmp-name2))) ;; Different permissions mean different ACLs. - (set-file-modes tmp-name1 #o777) - (set-file-modes tmp-name2 #o444) - (should-not - (string-equal (file-acl tmp-name1) (file-acl tmp-name2))) - ;; Copy ACL. - (should (set-file-acl tmp-name2 (file-acl tmp-name1))) - (should (string-equal (file-acl tmp-name1) (file-acl tmp-name2))) + (when (not (tramp--test-windows-nt-or-smb-p)) + (set-file-modes tmp-name1 #o777) + (set-file-modes tmp-name2 #o444) + (should-not + (string-equal (file-acl tmp-name1) (file-acl tmp-name2)))) + ;; Copy ACL. Not all remote handlers support it, so we test. + (when (set-file-acl tmp-name2 (file-acl tmp-name1)) + (should (string-equal (file-acl tmp-name1) (file-acl tmp-name2)))) ;; An invalid ACL does not harm. (should-not (set-file-acl tmp-name2 "foo"))) @@ -3028,9 +3029,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (not (equal (file-selinux-context tramp-test-temporary-file-directory) '(nil nil nil nil)))) - ;; TODO: The quoted case does not work. Copy local file to remote. - ;;(dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) - (let (quoted) + ;; `filename-non-special' has been fixed in Emacs 26.1, see Bug#29579. + (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs26-p)) + '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -3823,8 +3824,6 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (format "#%s#" (file-name-nondirectory tmp-name1)) tramp-test-temporary-file-directory)))))) - ;; TODO: The following two cases don't work yet. - (when nil ;; Use default `tramp-auto-save-directory' mechanism. (let ((tramp-auto-save-directory tmp-name2)) (with-temp-buffer @@ -3869,7 +3868,6 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (tramp-compat-file-name-unquote tmp-name1))) tmp-name2))) (should (file-directory-p tmp-name2))))) - ) ;; TODO ;; Cleanup. (ignore-errors (delete-file tmp-name1)) @@ -4084,9 +4082,9 @@ This requires restrictions of file name syntax." (defun tramp--test-check-files (&rest files) "Run a simple but comprehensive test over every file in FILES." - ;; TODO: The quoted case does not work. - ;;(dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) - (let (quoted) + ;; `filename-non-special' has been fixed in Emacs 26.1, see Bug#29579. + (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs26-p)) + '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, ;; because it could be located on a symlinked directory. This ;; would let the test fail. commit 01db80046f41c94569efd5dcdb11a1e46b3f16f3 Merge: 3ef212ce82 7eea3144d4 Author: Michael Albinus Date: Sat Dec 9 11:23:03 2017 +0100 Merge from origin/emacs-26 7eea3144d4 Minor Tramp fixes c0a670a8b5 * lisp/help-mode.el (help-function-def): Allow help-make-x... 05720162c1 Fix doc-string of 'display-buffer-in-side-window' a1bbc49015 Fix Bug#29579 cb3d979b74 ; NEWS: Update Org version number commit 7eea3144d4863325ff249b1fde290c3280da4a61 Author: Michael Albinus Date: Fri Dec 8 16:37:53 2017 +0100 Minor Tramp fixes * lisp/net/tramp-gvfs.el (tramp-gvfs-do-copy-or-rename-file): Fix a bug when renaming. * test/lisp/net/tramp-tests.el (tramp-test21-file-links): Extend test. (tramp-test42-delay-load, tramp-test42-remote-load-path): Skip unless Emacs >= 26. diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index fe5a98909e..1d1b04b44f 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -683,7 +683,6 @@ file names." (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname)) (equal-remote (tramp-equal-remote filename newname)) - (file-operation (intern (format "%s-file" op))) (gvfs-operation (if (eq op 'copy) "gvfs-copy" "gvfs-move")) (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) @@ -698,9 +697,11 @@ file names." ;; We cannot copy or rename directly. (let ((tmpfile (tramp-compat-make-temp-file filename))) - (funcall - file-operation filename tmpfile t keep-date preserve-uid-gid - preserve-extended-attributes) + (if (eq op 'copy) + (copy-file + filename tmpfile t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file filename tmpfile t)) (rename-file tmpfile newname ok-if-already-exists)) ;; Direct action. diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 0490daa957..1261a81378 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2810,7 +2810,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Symbolic links could look like a remote file name. ;; They must be quoted then. (delete-file tmp-name2) - (make-symbolic-link "/penguin:motd:" tmp-name2) + (make-symbolic-link + (funcall + (if quoted 'tramp-compat-file-name-unquote 'identity) + "/penguin:motd:") + tmp-name2) (should (file-symlink-p tmp-name2)) (should (string-equal @@ -4631,6 +4635,10 @@ process sentinels. They shall not disturb each other." (ert-deftest tramp-test42-delay-load () "Check that Tramp is loaded lazily, only when needed." + ;; The autoloaded Tramp objects are different since Emacs 26.1. We + ;; cannot test older Emacsen, therefore. + (skip-unless (tramp--test-emacs26-p)) + ;; Tramp is neither loaded at Emacs startup, nor when completing a ;; non-Tramp file name like "/foo". Completing a Tramp-alike file ;; name like "/foo:" autoloads Tramp, when `tramp-mode' is t. @@ -4643,8 +4651,8 @@ process sentinels. They shall not disturb each other." (message \"Tramp loaded: %%s\" (featurep 'tramp)) \ (file-name-all-completions \"/foo:\" \"/\") \ (message \"Tramp loaded: %%s\" (featurep 'tramp)))")) - ;; Tramp doesn't load when `tramp-mode' is nil since Emacs 26.1. - (dolist (tm (if (tramp--test-emacs26-p) '(t nil) '(nil))) + ;; Tramp doesn't load when `tramp-mode' is nil. + (dolist (tm '(t nil)) (should (string-match (format @@ -4682,6 +4690,10 @@ process sentinels. They shall not disturb each other." (ert-deftest tramp-test42-remote-load-path () "Check that Tramp autoloads its packages with remote `load-path'." + ;; The autoloaded Tramp objects are different since Emacs 26.1. We + ;; cannot test older Emacsen, therefore. + (skip-unless (tramp--test-emacs26-p)) + ;; `tramp-cleanup-all-connections' is autoloaded from tramp-cmds.el. ;; It shall still work, when a remote file name is in the ;; `load-path'. @@ -4759,6 +4771,8 @@ Since it unloads Tramp, it shall be the last test to run." ;; * dired-compress-file ;; * dired-uncache +;; * file-equal-p (partly done in `tramp-test21-file-links') +;; * file-in-directory-p ;; * file-name-case-insensitive-p ;; * Work on skipped tests. Make a comment, when it is impossible. commit c0a670a8b5833b81ef82c3f08ba9ddd68412ebe0 Author: Glenn Morris Date: Thu Dec 7 20:30:39 2017 -0500 * lisp/help-mode.el (help-function-def): Allow help-make-xrefs to call with one argument. (Bug#29611) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index a98bce0138..8bafa46aa9 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -192,20 +192,24 @@ The format is (FUNCTION ARGS...).") (define-button-type 'help-function-def :supertype 'help-xref - 'help-function (lambda (fun file &optional type) - (require 'find-func) - (when (eq file 'C-source) - (setq file - (help-C-file-name (indirect-function fun) 'fun))) - ;; Don't use find-function-noselect because it follows - ;; aliases (which fails for built-in functions). - (let ((location - (find-function-search-for-symbol fun type file))) - (pop-to-buffer (car location)) - (run-hooks 'find-function-after-hook) - (if (cdr location) - (goto-char (cdr location)) - (message "Unable to find location in file")))) + 'help-function (lambda (fun &optional file type) + (or file + (setq file (find-lisp-object-file-name fun type))) + (if (not file) + (message "Unable to find defining file") + (require 'find-func) + (when (eq file 'C-source) + (setq file + (help-C-file-name (indirect-function fun) 'fun))) + ;; Don't use find-function-noselect because it follows + ;; aliases (which fails for built-in functions). + (let ((location + (find-function-search-for-symbol fun type file))) + (pop-to-buffer (car location)) + (run-hooks 'find-function-after-hook) + (if (cdr location) + (goto-char (cdr location)) + (message "Unable to find location in file"))))) 'help-echo (purecopy "mouse-2, RET: find function's definition")) (define-button-type 'help-function-cmacro ; FIXME: Obsolete since 24.4. @@ -495,12 +499,6 @@ that." (help-xref-button 8 'help-face sym))) ((match-string 6)) ; nothing for `symbol' ((match-string 7) - ;; this used: - ;; #'(lambda (arg) - ;; (let ((location - ;; (find-function-noselect arg))) - ;; (pop-to-buffer (car location)) - ;; (goto-char (cdr location)))) (help-xref-button 8 'help-function-def sym)) ((cl-some (lambda (x) (funcall (nth 1 x) sym)) describe-symbol-backends) commit 05720162c1616ca76093f5569e3081dc515993a9 Author: Martin Rudalics Date: Thu Dec 7 09:55:21 2017 +0100 Fix doc-string of 'display-buffer-in-side-window' * lisp/window.el (display-buffer-in-side-window): In doc-string clarify why the window returned gets dedicated to its buffer. diff --git a/lisp/window.el b/lisp/window.el index b7736d85cd..c4572106f4 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -1008,8 +1008,9 @@ do not permit making a new window, a suitable existing window may be reused and have its `window-slot' parameter value accordingly modified. -Unless `display-buffer-mark-dedicated' is non-nil, softly -dedicate the side window used to BUFFER. Return the window used +Unless `display-buffer-mark-dedicated' is non-nil, dedicate the +side window used to BUFFER so that it does not get reused by +other `display-buffer' action functions. Return the window used for displaying BUFFER, nil if no suitable window can be found. This function installs the `window-side' and `window-slot' commit a1bbc490155b61a634a6d0b165000ce35b93aa35 Author: Michael Albinus Date: Wed Dec 6 20:49:30 2017 +0100 Fix Bug#29579 * lisp/files.el (file-name-non-special): Inhibit `file-name-handler-alist' only for some operations. Add missing operations. (Bug#29579) * lisp/net/tramp-compat.el (tramp-compat-file-name-quote): Do not quote if it is quoted already. * lisp/net/tramp-smb.el (tramp-smb-handle-insert-directory): Use `copy-tree' but `copy-sequence'. * lisp/net/tramp.el (tramp-handle-file-truename): Handle several trailing slashes correctly. * test/lisp/net/tramp-tests.el (tramp-test11-copy-file) (tramp-test12-rename-file, tramp-test24-file-acl) (tramp-test25-file-selinux, tramp--test-check-files): Handle also quoted file names. (tramp-test21-file-links): Fix file name quoting test. (tramp-test24-file-acl): Be more robust for "smb" method. (tramp-test35-make-auto-save-file-name): Enable hidden test cases. diff --git a/lisp/files.el b/lisp/files.el index ef4c2ea818..4b6d4e88ac 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -6975,60 +6975,67 @@ only these files will be asked to be saved." ;; We depend on being the last handler on the list, ;; so that anything else which does need handling ;; has been handled already. -;; So it is safe for us to inhibit *all* magic file name handlers. +;; So it is safe for us to inhibit *all* magic file name handlers for +;; operations, which return a file name. See Bug#29579. (defun file-name-non-special (operation &rest arguments) - (let ((file-name-handler-alist nil) - (default-directory - ;; Some operations respect file name handlers in - ;; `default-directory'. Because core function like - ;; `call-process' don't care about file name handlers in - ;; `default-directory', we here have to resolve the - ;; directory into a local one. For `process-file', - ;; `start-file-process', and `shell-command', this fixes - ;; Bug#25949. - (if (memq operation '(insert-directory process-file start-file-process - shell-command)) - (directory-file-name - (expand-file-name - (unhandled-file-name-directory default-directory))) - default-directory)) - ;; Get a list of the indices of the args which are file names. - (file-arg-indices - (cdr (or (assq operation - ;; The first six are special because they - ;; return a file name. We want to include the /: - ;; in the return value. - ;; So just avoid stripping it in the first place. - '((expand-file-name . nil) - (file-name-directory . nil) - (file-name-as-directory . nil) - (directory-file-name . nil) - (file-name-sans-versions . nil) - (find-backup-file-name . nil) - ;; `identity' means just return the first arg - ;; not stripped of its quoting. - (substitute-in-file-name identity) - ;; `add' means add "/:" to the result. - (file-truename add 0) - (insert-file-contents insert-file-contents 0) - ;; `unquote-then-quote' means set buffer-file-name - ;; temporarily to unquoted filename. - (verify-visited-file-modtime unquote-then-quote) - ;; List the arguments which are filenames. - (file-name-completion 1) - (file-name-all-completions 1) - (write-region 2 5) - (rename-file 0 1) - (copy-file 0 1) - (make-symbolic-link 0 1) - (add-name-to-file 0 1))) - ;; For all other operations, treat the first argument only - ;; as the file name. - '(nil 0)))) - method - ;; Copy ARGUMENTS so we can replace elements in it. - (arguments (copy-sequence arguments))) + (let* ((op-returns-file-name-list + '(expand-file-name file-name-directory file-name-as-directory + directory-file-name file-name-sans-versions + find-backup-file-name file-remote-p)) + (file-name-handler-alist + (and + (not (memq operation op-returns-file-name-list)) + file-name-handler-alist)) + (default-directory + ;; Some operations respect file name handlers in + ;; `default-directory'. Because core function like + ;; `call-process' don't care about file name handlers in + ;; `default-directory', we here have to resolve the + ;; directory into a local one. For `process-file', + ;; `start-file-process', and `shell-command', this fixes + ;; Bug#25949. + (if (memq operation + '(insert-directory process-file start-file-process + shell-command)) + (directory-file-name + (expand-file-name + (unhandled-file-name-directory default-directory))) + default-directory)) + ;; Get a list of the indices of the args which are file names. + (file-arg-indices + (cdr (or (assq operation + ;; The first seven are special because they + ;; return a file name. We want to include the /: + ;; in the return value. + ;; So just avoid stripping it in the first place. + (append + (mapcar 'list op-returns-file-name-list) + '(;; `identity' means just return the first arg + ;; not stripped of its quoting. + (substitute-in-file-name identity) + ;; `add' means add "/:" to the result. + (file-truename add 0) + (insert-file-contents insert-file-contents 0) + ;; `unquote-then-quote' means set buffer-file-name + ;; temporarily to unquoted filename. + (verify-visited-file-modtime unquote-then-quote) + ;; List the arguments which are filenames. + (file-name-completion 1) + (file-name-all-completions 1) + (write-region 2 5) + (rename-file 0 1) + (copy-file 0 1) + (copy-directory 0 1) + (file-in-directory-p 0 1) + (make-symbolic-link 0 1) + (add-name-to-file 0 1)))) + ;; For all other operations, treat the first argument only + ;; as the file name. + '(nil 0)))) + method + ;; Copy ARGUMENTS so we can replace elements in it. + (arguments (copy-sequence arguments))) (if (symbolp (car file-arg-indices)) (setq method (pop file-arg-indices))) ;; Strip off the /: from the file names that have it. diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 9326f7b186..9cdfc06512 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -210,8 +210,10 @@ If NAME is a remote file name, check the local part of NAME." (defsubst tramp-compat-file-name-quote (name) "Add the quotation prefix \"/:\" to file NAME. If NAME is a remote file name, the local part of NAME is quoted." - (concat - (file-remote-p name) "/:" (or (file-remote-p name 'localname) name)))) + (if (tramp-compat-file-name-quoted-p name) + name + (concat + (file-remote-p name) "/:" (or (file-remote-p name 'localname) name))))) (if (fboundp 'file-name-unquote) (defalias 'tramp-compat-file-name-unquote 'file-name-unquote) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index acb5a12ba2..14c1a4049a 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1036,6 +1036,7 @@ of command line.") (load . tramp-handle-load) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-sh-handle-make-directory) + ;; `make-directory-internal' performed by default handler. (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-symbolic-link . tramp-sh-handle-make-symbolic-link) (process-file . tramp-sh-handle-process-file) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index eb0d6b5073..a4d4b4e0bc 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -437,7 +437,7 @@ pass to the OPERATION." (delete-directory tmpdir 'recursive)))) ;; We can copy recursively. - ;; Does not work reliably. + ;; TODO: Does not work reliably. (nil ;(and (or t1 t2) (tramp-smb-get-cifs-capabilities v)) (when (and (file-directory-p newname) (not (string-equal (file-name-nondirectory dirname) @@ -1015,7 +1015,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (save-match-data (let ((base (file-name-nondirectory filename)) ;; We should not destroy the cache entry. - (entries (copy-sequence + (entries (copy-tree (tramp-smb-get-file-entries (file-name-directory filename)))) (avail (get-free-disk-space filename)) @@ -1441,7 +1441,7 @@ component is used as the target of the symlink." (tramp-set-connection-property v "process-buffer" (current-buffer)) - ;; Use an asynchronous processes. By this, password can + ;; Use an asynchronous process. By this, password can ;; be handled. (let ((p (apply 'start-process @@ -1456,6 +1456,9 @@ component is used as the target of the symlink." (set-process-query-on-exit-flag p nil) (tramp-process-actions p v nil tramp-smb-actions-set-acl) (goto-char (point-max)) + ;; This is meant for traces, and returning from the + ;; function. No error is propagated outside, due to + ;; the `ignore-errors' closure. (unless (re-search-backward "tramp_exit_status [0-9]+" nil t) (tramp-error v 'file-error diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 124da17348..2fdc651a37 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -670,8 +670,8 @@ It can have the following values: `simplified' -- Ange-FTP like syntax `separate' -- Syntax as defined for XEmacs originally -Do not change the value by `setq', it must be changed only by -`custom-set-variables'. See also `tramp-change-syntax'." +Do not change the value by `setq', it must be changed only via +Customize. See also `tramp-change-syntax'." :group 'tramp :version "26.1" :package-version '(Tramp . "2.3.3") @@ -3217,7 +3217,7 @@ User is always nil." (tramp-error v1 'file-error "Maximum number (%d) of symlinks exceeded" numchase-limit))) - result)) + (directory-file-name result))) ;; Preserve trailing "/". (if (string-equal (file-name-nondirectory filename) "") "/" "")))) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index b0fe3f83e9..0490daa957 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -1882,9 +1882,9 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `copy-file'." (skip-unless (tramp--test-enabled)) - ;; TODO: The quoted case does not work. Copy local file to remote. - ;;(dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) - (let (quoted) + ;; `filename-non-special' has been fixed in Emacs 26.1, see Bug#29579. + (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs26-p)) + '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -1984,9 +1984,9 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `rename-file'." (skip-unless (tramp--test-enabled)) - ;; TODO: The quoted case does not work. - ;;(dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) - (let (quoted) + ;; `filename-non-special' has been fixed in Emacs 26.1, see Bug#29579. + (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs26-p)) + '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -2825,7 +2825,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; We must unquote it. (should (string-equal - (file-truename tmp-name1) + (tramp-compat-file-name-unquote (file-truename tmp-name1)) (tramp-compat-file-name-unquote (file-truename tmp-name3))))) ;; Cleanup. @@ -2951,9 +2951,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (tramp--test-enabled)) (skip-unless (file-acl tramp-test-temporary-file-directory)) - ;; TODO: The quoted case does not work. Copy local file to remote. - ;;(dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) - (let (quoted) + ;; `filename-non-special' has been fixed in Emacs 26.1, see Bug#29579. + (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs26-p)) + '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -2968,13 +2968,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (file-acl tmp-name2)) (should (string-equal (file-acl tmp-name1) (file-acl tmp-name2))) ;; Different permissions mean different ACLs. - (set-file-modes tmp-name1 #o777) - (set-file-modes tmp-name2 #o444) - (should-not - (string-equal (file-acl tmp-name1) (file-acl tmp-name2))) - ;; Copy ACL. - (should (set-file-acl tmp-name2 (file-acl tmp-name1))) - (should (string-equal (file-acl tmp-name1) (file-acl tmp-name2))) + (when (not (tramp--test-windows-nt-or-smb-p)) + (set-file-modes tmp-name1 #o777) + (set-file-modes tmp-name2 #o444) + (should-not + (string-equal (file-acl tmp-name1) (file-acl tmp-name2)))) + ;; Copy ACL. Not all remote handlers support it, so we test. + (when (set-file-acl tmp-name2 (file-acl tmp-name1)) + (should (string-equal (file-acl tmp-name1) (file-acl tmp-name2)))) ;; An invalid ACL does not harm. (should-not (set-file-acl tmp-name2 "foo"))) @@ -3028,9 +3029,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (not (equal (file-selinux-context tramp-test-temporary-file-directory) '(nil nil nil nil)))) - ;; TODO: The quoted case does not work. Copy local file to remote. - ;;(dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) - (let (quoted) + ;; `filename-non-special' has been fixed in Emacs 26.1, see Bug#29579. + (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs26-p)) + '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -3823,8 +3824,6 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (format "#%s#" (file-name-nondirectory tmp-name1)) tramp-test-temporary-file-directory)))))) - ;; TODO: The following two cases don't work yet. - (when nil ;; Use default `tramp-auto-save-directory' mechanism. (let ((tramp-auto-save-directory tmp-name2)) (with-temp-buffer @@ -3869,7 +3868,6 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (tramp-compat-file-name-unquote tmp-name1))) tmp-name2))) (should (file-directory-p tmp-name2))))) - ) ;; TODO ;; Cleanup. (ignore-errors (delete-file tmp-name1)) @@ -4084,9 +4082,9 @@ This requires restrictions of file name syntax." (defun tramp--test-check-files (&rest files) "Run a simple but comprehensive test over every file in FILES." - ;; TODO: The quoted case does not work. - ;;(dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) - (let (quoted) + ;; `filename-non-special' has been fixed in Emacs 26.1, see Bug#29579. + (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs26-p)) + '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, ;; because it could be located on a symlinked directory. This ;; would let the test fail. commit cb3d979b740d163088610067a5eec87c0d34fea9 Author: Rasmus Date: Wed Dec 6 15:24:22 2017 +0100 ; NEWS: Update Org version number diff --git a/etc/NEWS b/etc/NEWS index 4ccf468693..64b53d88c8 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -626,7 +626,7 @@ state to take effect (making a frame visible, for example). * Changes in Specialized Modes and Packages in Emacs 26.1 --- -** Emacs 26.1 comes with Org v9.1.2. +** Emacs 26.1 comes with Org v9.1.4. See the file ORG-NEWS for user-visible changes in Org. ---