From e5f50f32f76bab2607d77f0dc51cf81ec0c1e232 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Wed, 17 Feb 2021 18:04:35 +0100 Subject: Further Tramp code cleanup * doc/misc/tramp.texi (Predefined connection information): Mention "about-args". * lisp/net/tramp-cmds.el (tramp-version): Adapt docstring. * lisp/net/tramp.el (tramp-handle-expand-file-name): * lisp/net/tramp-gvfs.el (tramp-gvfs-handle-expand-file-name): * lisp/net/tramp-sh.el (tramp-sh-handle-expand-file-name) * lisp/net/tramp-smb.el (tramp-smb-handle-expand-file-name): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-handle-expand-file-name): Handle local "/..". * lisp/net/tramp-rclone.el (tramp-methods) : Adapt `tramp-mount-args'. (tramp-rclone-flush-directory-cache): Remove. (tramp-rclone-do-copy-or-rename-file) (tramp-rclone-handle-delete-directory) (tramp-rclone-handle-delete-file) (tramp-rclone-handle-make-directory): Don't use that function. (tramp-rclone-maybe-open-connection): Fix use of `tramp-mount-args'. * lisp/net/trampver.el (tramp-inside-emacs): New defun. * lisp/net/tramp.el (tramp-handle-make-process): * lisp/net/tramp-sh.el (tramp-sh-handle-make-process) (tramp-sh-handle-process-file, tramp-open-shell): Use it. (tramp-get-env-with-u-option): Remove. * test/lisp/net/tramp-tests.el (tramp-test05-expand-file-name-top): New test. --- lisp/net/tramp-sh.el | 39 ++++++++++----------------------------- 1 file changed, 10 insertions(+), 29 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index bcdc014daba..57301994074 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2818,6 +2818,9 @@ the result will be a local, non-Tramp, file name." ;; expands to "/". Remove this. (while (string-match "//" localname) (setq localname (replace-match "/" t t localname))) + ;; Do not keep "/..". + (when (string-match-p "^/\\.\\.?$" localname) + (setq localname "/")) ;; No tilde characters in file name, do normal ;; `expand-file-name' (this does "/./" and "/../"). ;; `default-directory' is bound, because on Windows there would @@ -2927,16 +2930,11 @@ alternative implementation will be used." elt (default-toplevel-value 'process-environment)) (if (string-match-p "=" elt) (setq env (append env `(,elt))) - (if (tramp-get-env-with-u-option v) - (setq env (append `("-u" ,elt) env)) - (setq uenv (cons elt uenv))))))) + (setq uenv (cons elt uenv)))))) + (env (setenv-internal + env "INSIDE_EMACS" (tramp-inside-emacs) 'keep)) (command (when (stringp program) - (setenv-internal - env "INSIDE_EMACS" - (concat (or (getenv "INSIDE_EMACS") emacs-version) - ",tramp:" tramp-version) - 'keep) (format "cd %s && %s exec %s %s env %s %s" (tramp-shell-quote-argument localname) (if uenv @@ -3147,14 +3145,8 @@ alternative implementation will be used." (or (member elt (default-toplevel-value 'process-environment)) (if (string-match-p "=" elt) (setq env (append env `(,elt))) - (if (tramp-get-env-with-u-option v) - (setq env (append `("-u" ,elt) env)) - (setq uenv (cons elt uenv)))))) - (setenv-internal - env "INSIDE_EMACS" - (concat (or (getenv "INSIDE_EMACS") emacs-version) - ",tramp:" tramp-version) - 'keep) + (setq uenv (cons elt uenv))))) + (setenv-internal env "INSIDE_EMACS" (tramp-inside-emacs) 'keep) (when env (setq command (format @@ -4307,10 +4299,9 @@ file exists and nonzero exit status otherwise." (tramp-send-command vec (format (concat - "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " + "exec env TERM='%s' INSIDE_EMACS='%s' " "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s -i") - tramp-terminal-type - (or (getenv "INSIDE_EMACS") emacs-version) tramp-version + tramp-terminal-type (tramp-inside-emacs) (or (getenv-internal "ENV" tramp-remote-process-environment) "") (if (stringp tramp-histfile-override) (format "HISTFILE=%s" @@ -5945,16 +5936,6 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." (tramp-file-local-name tmpfile) (tramp-file-local-name tmpfile))) (delete-file tmpfile))))) -(defun tramp-get-env-with-u-option (vec) - "Check, whether the remote `env' command supports the -u option." - (with-tramp-connection-property vec "env-u-option" - (tramp-message vec 5 "Checking, whether `env -u' works") - ;; Option "-u" is a GNU extension. - (tramp-send-command-and-check - vec (format "env FOO=foo env -u FOO 2>%s | grep -qv FOO" - (tramp-get-remote-null-device vec)) - t))) - ;; Some predefined connection properties. (defun tramp-get-inline-compress (vec prop size) "Return the compress command related to PROP. -- cgit v1.2.3 From 11d3af3c7b9dc5a2910807d311168fb82d962d0d Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Mon, 8 Mar 2021 12:05:29 +0100 Subject: Add Tramp sshfs method * doc/misc/tramp.texi (Top, Configuration): Insert sections 'FUSE-based methods' and 'FUSE setup' in menu. (Quick Start Guide): Fix @anchors. Add doas. Extend section 'Using @command{rclone}' to 'Using @acronym{FUSE}-based methods'. (External methods): Remove rclone paragraph. (FUSE-based methods, FUSE setup): New nodes. (Predefined connection information): Mention "mount-point". * etc/NEWS: Mention Tramp sshfs method. Fix typos and other oddities. * lisp/net/tramp-fuse.el: New file. * lisp/net/tramp-rclone.el (tramp-fuse): Require. (tramp-rclone-file-name-handler-alist): Replace `tramp-rclone-handle-*' by `tramp-fuse-handle-*' where appropriate. (tramp-rclone-handle-delete-directory) (tramp-rclone-handle-delete-file) (tramp-rclone-handle-directory-files) (tramp-rclone-handle-file-attributes) (tramp-rclone-handle-file-executable-p) (tramp-rclone-handle-file-name-all-completions) (tramp-rclone-handle-file-readable-p) (tramp-rclone-handle-insert-directory) (tramp-rclone-handle-insert-file-contents) (tramp-rclone-handle-make-directory, tramp-rclone-mount-point) (tramp-rclone-mounted-p, tramp-rclone-local-file-name): Remove. Functionality moved to tramp-fuse.el. (tramp-rclone-remote-file-name) (tramp-rclone-maybe-open-connection): Use `tramp-fuse-*' functions. * lisp/net/tramp-sh.el (tramp-do-copy-or-rename-file-out-of-band): Simplify check. * lisp/net/tramp-sshfs.el: New file. * lisp/net/tramp.el: Remove TODO item. * test/lisp/net/tramp-tests.el (tramp--test-sshfs-p): New defun. (tramp-test14-delete-directory): Use it. --- doc/misc/tramp.texi | 278 ++++++++++++++++++++++++++----------- etc/NEWS | 66 +++++---- lisp/net/tramp-fuse.el | 205 ++++++++++++++++++++++++++++ lisp/net/tramp-rclone.el | 188 +++---------------------- lisp/net/tramp-sh.el | 4 +- lisp/net/tramp-sshfs.el | 318 +++++++++++++++++++++++++++++++++++++++++++ lisp/net/tramp.el | 5 - test/lisp/net/tramp-tests.el | 17 ++- 8 files changed, 789 insertions(+), 292 deletions(-) create mode 100644 lisp/net/tramp-fuse.el create mode 100644 lisp/net/tramp-sshfs.el (limited to 'lisp/net/tramp-sh.el') diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 2c9348f6d0d..5958162d937 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -126,6 +126,7 @@ Configuring @value{tramp} for use * Inline methods:: Inline methods. * External methods:: External methods. * GVFS-based methods:: @acronym{GVFS}-based external methods. +* FUSE-based methods:: @acronym{FUSE}-based external methods. * Default Method:: Selecting a default method. * Default User:: Selecting a default user. * Default Host:: Selecting a default host. @@ -139,6 +140,7 @@ Configuring @value{tramp} for use Setting own connection related information. * Remote programs:: How @value{tramp} finds and uses programs on the remote host. * Remote shell setup:: Remote shell setup hints. +* FUSE setup:: @acronym{FUSE} setup hints. * Android shell setup:: Android shell setup hints. * Auto-save and Backup:: Auto-save and Backup. * Keeping files encrypted:: Protect remote files by encryption. @@ -433,7 +435,7 @@ remote host, when the buffer you call the process from has a remote @code{default-directory}. -@anchor{Quick Start Guide: File name syntax} +@anchor{Quick Start Guide File name syntax} @section File name syntax @cindex file name syntax @@ -459,7 +461,7 @@ connection methods also support a notation for the port to be used, in which case it is written as @code{host#port}. -@anchor{Quick Start Guide: @option{ssh} and @option{plink} methods} +@anchor{Quick Start Guide ssh and plink methods} @section Using @option{ssh} and @option{plink} @cindex method @option{ssh} @cindex @option{ssh} method @@ -478,28 +480,31 @@ an @command{ssh} server: @file{@trampfn{plink,user@@host,/path/to/file}}. -@anchor{Quick Start Guide: @option{su}, @option{sudo} and @option{sg} methods} -@section Using @option{su}, @option{sudo} and @option{sg} +@anchor{Quick Start Guide su, sudo, doas and sg methods} +@section Using @option{su}, @option{sudo}, @option{doas} and @option{sg} @cindex method @option{su} @cindex @option{su} method @cindex method @option{sudo} @cindex @option{sudo} method +@cindex method @option{doas} +@cindex @option{doas} method @cindex method @option{sg} @cindex @option{sg} method Sometimes, it is necessary to work on your local host under different permissions. For this, you can use the @option{su} or @option{sudo} -connection method. Both methods use @samp{root} as default user name -and the return value of @code{(system-name)} as default host name. -Therefore, it is convenient to open a file as +connection method. On OpenBSD systems, the @option{doas} connection +method offers the same functionality. These methods use @samp{root} +as default user name and the return value of @code{(system-name)} as +default host name. Therefore, it is convenient to open a file as @file{@trampfn{sudo,,/path/to/file}}. The method @option{sg} stands for ``switch group''; here the user name is used as the group to change to. The default host name is the same. -@anchor{Quick Start Guide: @option{ssh}, @option{plink}, @option{su}, @option{sudo} and @option{sg} methods} -@section Combining @option{ssh} or @option{plink} with @option{su} or @option{sudo} +@anchor{Quick Start Guide Combining ssh, plink, su, sudo and doas methods} +@section Combining @option{ssh} or @option{plink} with @option{su}, @option{sudo} or @option{doas} @cindex method @option{ssh} @cindex @option{ssh} method @cindex method @option{plink} @@ -508,18 +513,20 @@ is used as the group to change to. The default host name is the same. @cindex @option{su} method @cindex method @option{sudo} @cindex @option{sudo} method +@cindex method @option{doas} +@cindex @option{doas} method -If the @option{su} or @option{sudo} option should be performed on -another host, it can be comnbined with a leading @option{ssh} or -@option{plink} option. That means that @value{tramp} connects first to -the other host with non-administrative credentials, and changes to -administrative credentials on that host afterwards. In a simple case, -the syntax looks like +If the @option{su}, @option{sudo} or @option{doas} option should be +performed on another host, it can be comnbined with a leading +@option{ssh} or @option{plink} option. That means that @value{tramp} +connects first to the other host with non-administrative credentials, +and changes to administrative credentials on that host afterwards. In +a simple case, the syntax looks like @file{@value{prefix}ssh@value{postfixhop}user@@host|sudo@value{postfixhop}@value{postfix}/path/to/file}. @xref{Ad-hoc multi-hops}. -@anchor{Quick Start Guide: @option{sudoedit} method} +@anchor{Quick Start Guide sudoedit method} @section Using @command{sudoedit} @cindex method @option{sudoedit} @cindex @option{sudoedit} method @@ -532,7 +539,7 @@ method, it is restricted to @samp{localhost} only, and it does not support external processes. -@anchor{Quick Start Guide: @option{smb} method} +@anchor{Quick Start Guide smb method} @section Using @command{smbclient} @cindex method @option{smb} @cindex @option{smb} method @@ -546,7 +553,7 @@ of the local file name is the share exported by the remote host, @samp{path} in this example. -@anchor{Quick Start Guide: GVFS-based methods} +@anchor{Quick Start Guide GVFS-based methods} @section Using @acronym{GVFS}-based methods @cindex methods, gvfs @cindex gvfs-based methods @@ -570,7 +577,7 @@ file system), @file{@trampfn{dav,user@@host,/path/to/file}}, @file{@trampfn{mtp,device,/path/to/file}} (for media devices). -@anchor{Quick Start Guide: GNOME Online Accounts based methods} +@anchor{Quick Start Guide GNOME Online Accounts based methods} @section Using @acronym{GNOME} Online Accounts based methods @cindex @acronym{GNOME} Online Accounts @cindex method @option{gdrive} @@ -590,21 +597,18 @@ account), or @file{@trampfn{nextcloud,user@@host#8081,/path/to/file}} (@samp{8081} stands for the port number) for OwnCloud/NextCloud files. -@anchor{Quick Start Guide: Android} -@section Using Android -@cindex method @option{adb} -@cindex @option{adb} method -@cindex android - -An Android device, which is connected via USB to your local host, can -be accessed via the @command{adb} command. No user or host name is -needed. The file name syntax is @file{@trampfn{adb,,/path/to/file}}. - - -@anchor{Quick Start Guide: @option{rclone} method} -@section Using @command{rclone} +@anchor{Quick Start Guide FUSE-based methods} +@section Using @acronym{FUSE}-based methods +@cindex methods, fuse +@cindex fuse-based methods @cindex method @option{rclone} @cindex @option{rclone} method +@cindex method @option{sshfs} +@cindex @option{sshfs} method + +@acronym{FUSE, Filesystem in Userspace} allows users to mount a +virtual file system. It is also used by @acronym{GVFS} internally, +but here we discuss methods which do not use the @acronym{GVFS} API. A convenient way to access system storages is the @command{rclone} program. If you have configured a storage in @command{rclone} under a @@ -612,6 +616,24 @@ name @samp{storage} (for example), you can access it via the remote file name syntax @file{@trampfn{rclone,storage,/path/to/file}}. User names are not needed. +On local hosts which have installed the @command{sshfs} client for +mounting a file system based on @command{sftp}, this method can be +used. All remote files are available via the local mount point. +@value{tramp} aids in mounting the file system if it isn't mounted +yet, and it supports the access with the usual file name syntax +@file{@trampfn{sshfs,user@@host,/path/to/file}}. + + +@anchor{Quick Start Guide Android} +@section Using Android +@cindex method @option{adb} +@cindex @option{adb} method +@cindex android + +An Android device, which is connected via USB to your local host, can +be accessed via the @command{adb} command. No user or host name is +needed. The file name syntax is @file{@trampfn{adb,,/path/to/file}}. + @node Configuration @chapter Configuring @value{tramp} @@ -650,6 +672,7 @@ may be used in your init file: * Inline methods:: Inline methods. * External methods:: External methods. * GVFS-based methods:: @acronym{GVFS}-based external methods. +* FUSE-based methods:: @acronym{FUSE}-based external methods. * Default Method:: Selecting a default method. Here we also try to help those who don't have the foggiest which method @@ -666,6 +689,7 @@ may be used in your init file: Setting own connection related information. * Remote programs:: How @value{tramp} finds and uses programs on the remote host. * Remote shell setup:: Remote shell setup hints. +* FUSE setup:: @acronym{FUSE} setup hints. * Android shell setup:: Android shell setup hints. * Auto-save and Backup:: Auto-save and Backup. * Keeping files encrypted:: Protect remote files by encryption. @@ -1110,7 +1134,6 @@ UNC file name specification does not allow the specification of a different user name for authentication like the @command{smbclient} can. - @item @option{adb} @cindex method @option{adb} @cindex @option{adb} method @@ -1150,45 +1173,6 @@ specified using @file{device#42} host name syntax or @value{tramp} can use the default value as declared in @command{adb} command. Port numbers are not applicable to Android devices connected through USB@. - -@item @option{rclone} -@cindex method @option{rclone} -@cindex @option{rclone} method - -@vindex tramp-rclone-program -The program @command{rclone} allows to access different system -storages in the cloud, see @url{https://rclone.org/} for a list of -supported systems. If the @command{rclone} program isn't found in -your @env{PATH} environment variable, you can tell @value{tramp} its -absolute path via the user option @code{tramp-rclone-program}. - -A system storage must be configured via the @command{rclone config} -command, outside Emacs. If you have configured a storage in -@command{rclone} under a name @samp{storage} (for example), you could -access it via the remote file name - -@example -@trampfn{rclone,storage,/path/to/file} -@end example - -User names are part of the @command{rclone} configuration, and not -needed in the remote file name. If a user name is contained in the -remote file name, it is ignored. - -Internally, @value{tramp} mounts the remote system storage at location -@file{/tmp/tramp.rclone.storage}, with @file{storage} being the name -of the configured system storage. - -Optional flags to the different @option{rclone} operations could be -passed as connection property, @xref{Predefined connection -information}. Supported properties are @t{"mount-args"}, -@t{"copyto-args"}, @t{"moveto-args"} and @t{"about-args"}. - -Access via @option{rclone} is slow. If you have an alternative method -for accessing the system storage, you should use it. -@ref{GVFS-based methods} for example, methods @option{gdrive} and -@option{nextcloud}. - @end table @@ -1200,8 +1184,8 @@ for accessing the system storage, you should use it. @acronym{GVFS} is the virtual file system for the @acronym{GNOME} Desktop, @uref{https://en.wikipedia.org/wiki/GVFS}. Remote files on -@acronym{GVFS} are mounted locally through FUSE and @value{tramp} uses -this locally mounted directory internally. +@acronym{GVFS} are mounted locally through @acronym{FUSE} and +@value{tramp} uses this locally mounted directory internally. Emacs uses the D-Bus mechanism to communicate with @acronym{GVFS}@. Emacs must have the message bus system, D-Bus integration active, @@ -1317,6 +1301,88 @@ respectively: @end defopt +@node FUSE-based methods +@section @acronym{FUSE}-based external methods +@cindex methods, fuse +@cindex fuse-based methods + +Besides @acronym{GVFS}, there are other virtual file systems using the +@acronym{FUSE} interface. Remote files are mounted locally through +@acronym{FUSE} and @value{tramp} uses this locally mounted directory +internally. When possible, @value{tramp} maps the remote file names +to their respective local file name, and applies the file name +operation on them. For some of the file name operations this is not +possible, @value{tramp} emulates those operations otherwise. + +@table @asis +@item @option{rclone} +@cindex method @option{rclone} +@cindex @option{rclone} method + +@vindex tramp-rclone-program +The program @command{rclone} allows to access different system +storages in the cloud, see @url{https://rclone.org/} for a list of +supported systems. If the @command{rclone} program isn't found in +your @env{PATH} environment variable, you can tell @value{tramp} its +absolute path via the user option @code{tramp-rclone-program}. + +A system storage must be configured via the @command{rclone config} +command, outside Emacs. If you have configured a storage in +@command{rclone} under a name @samp{storage} (for example), you could +access it via the remote file name + +@example +@trampfn{rclone,storage,/path/to/file} +@end example + +User names are part of the @command{rclone} configuration, and not +needed in the remote file name. If a user name is contained in the +remote file name, it is ignored. + +Internally, @value{tramp} mounts the remote system storage at location +@file{/tmp/tramp.rclone.storage}, with @file{storage} being the name +of the configured system storage. + +The mount point and optional flags to the different @option{rclone} +operations could be passed as connection properties, @xref{Setup of +rclone method}. + +Access via @option{rclone} is slow. If you have an alternative method +for accessing the system storage, you should use it. +@ref{GVFS-based methods} for example, methods @option{gdrive} and +@option{nextcloud}. + +@item @option{sshfs} +@cindex method @option{sshfs} +@cindex @option{sshfs} method + +@vindex tramp-sshfs-program +On local hosts which have installed the @command{sshfs} client for +mounting a file system based on @command{sftp}, this method can be +used, see +@url{https://github.com/libfuse/sshfs/blob/master/README.rst/}. If +the @command{sshfs} program isn't found in your @env{PATH} environment +variable, you can tell @value{tramp} its absolute path via the user +option @code{tramp-sshfs-program}. + +All remote files are available via the local mount point. +@value{tramp} aids in mounting the file system if it isn't mounted +yet. The remote file name syntax is + +@example +@trampfn{sshfs,user@@host#port,/path/to/file} +@end example + +User name and port number are optional. This method does not support +password handling, the file system must either be mounted already, or +the connection must be established passwordless via ssh keys. + +The mount point and mount arguments could be passed as connection +properties, @xref{Setup of sshfs method}. + +@end table + + @node Default Method @section Selecting a default method @cindex default method @@ -2102,6 +2168,13 @@ The default value of this property is @code{t} (not specified in @code{tramp-methods}). If the remote host runs native MS Windows, this propery has no effect. +@item @t{"mount-point"} + +The directory file name an @acronym{FUSE}-based file system is mounted +on. The default value of this property is +@t{"/tmp/tramp.method.user@@host#port"} (not specified in +@code{tramp-methods}). + @item @t{"mount-args"}@* @t{"copyto-args"}@* @t{"moveto-args"}@* @@ -2430,7 +2503,6 @@ match the end of the connection buffer. Due to performance reasons, this search starts at the end of the buffer, and it is limited to 256 characters backwards. - @item Conflicting names for users and variables in @file{.profile} When a user name is the same as a variable name in a local file, such @@ -2440,7 +2512,6 @@ variable name to something different from the user name. For example, if the user name is @env{FRUMPLE}, then change the variable name to @env{FRUMPLE_DIR}. - @item Non-Bourne commands in @file{.profile} When the remote host's @file{.profile} is also used for shells other @@ -2465,7 +2536,6 @@ To accommodate using non-Bourne shells on that remote, use other shell-specific config files. For example, bash can use @file{~/.bash_profile} and ignore @file{.profile}. - @item Interactive shell prompt @vindex INSIDE_EMACS@r{, environment variable} @@ -2533,6 +2603,57 @@ where @samp{192.168.0.1} is the remote host IP address @end table +@node FUSE setup +@section @acronym{FUSE} setup hints + +The @acronym{FUSE} file systems are mounted per default at +@file{/tmp/tramp.method.user@@host#port}. The user name and port +number are optional. If the file system is already mounted, it will +be used as it is. If the mount point does not exist yet, +@value{tramp} creates this directory. + +The mount point can be overwritten by the connection property +@t{"mount-point"}, @ref{Predefined connection information}. +Example: + +@lisp +@group +(add-to-list 'tramp-connection-properties + `(,(regexp-quote "@trampfn{sshfs,user@@host,}") + "mount-point" + ,(expand-file-name "sshfs.user@@host" user-emacs-directory))) +@end group +@end lisp + + +@anchor{Setup of rclone method} +@subsection @option{rclone} setup +@cindex rclone setup + +The default arguments of the @command{rclone} operations +@command{mount}, @command{coopyto}, @command{moveto} and +@command{about} are declared in the variable @code{tramp-methods} as +method specific parameters. Usually, they don't need to be overwritten. + +If needed, these parameters can be overwritten as connection +properties @t{"mount-args"}, @t{"copyto-args"}, @t{"moveto-args"} and +@t{"about-args"}, @xref{Predefined connection information}. All of +them are list of strings. + +Be careful changing @t{"--dir-cache-time"}, this could delay +visibility of files. + + +@anchor{Setup of sshfs method} +@subsection @option{sshfs} setup +@cindex sshfs setup + +The method @option{sshfs} declares only the mount arguments, passed to +the @command{sshfs} command. This is a list of list of strings, and +can be overwritten by the connection property @t{"mount-args"}, +@xref{Predefined connection information}. + + @node Android shell setup @section Android shell setup hints @cindex android shell setup for ssh @@ -4197,6 +4318,7 @@ Disable excessive traces. Set @code{tramp-verbose} to 3 or lower, default being 3. Increase trace levels temporarily when hunting for bugs. + @item @value{tramp} does not connect to the remote host @@ -4448,6 +4570,7 @@ disable @samp{--color=yes} or @samp{--color=auto} in the remote host's @file{.bashrc} or @file{.profile}. Turn this alias on and off to see if file name completion works. + @item File name completion does not work in directories with large number of files @@ -4846,6 +4969,7 @@ In BBDB buffer, access an entry by pressing the key @kbd{F}. Thanks to @value{tramp} users for contributing to these recipes. + @item Why saved multi-hop file names do not work in a new Emacs session? diff --git a/etc/NEWS b/etc/NEWS index ce337e75171..26bed2af181 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -266,8 +266,8 @@ current mode. +++ ** New user option 'read-extended-command-predicate'. -This option controls how 'M-x' performs completion of commands when -you type TAB. By default, any command that matches what you have +This user option controls how 'M-x' performs completion of commands when +you type 'TAB'. By default, any command that matches what you have typed is considered a completion candidate, but you can customize this option to exclude commands that are not applicable to the current buffer's major and minor modes, and respect the command's completion @@ -369,25 +369,26 @@ Typing 'TAB' on a heading line cycles the current section between anywhere in the buffer cycles the whole buffer between "only top-level headings", "all headings and subheadings", and "show all" states. -*** New option 'outline-minor-mode-cycle'. -This option customizes 'outline-minor-mode', with the difference +*** New user option 'outline-minor-mode-cycle'. +This user option customizes 'outline-minor-mode', with the difference that 'TAB' and 'S-TAB' on heading lines cycle heading visibility. Typing 'TAB' on a heading line cycles the current section between "hide all", "subheadings", and "show all" states. Typing 'S-TAB' on a heading line cycles the whole buffer between "only top-level headings", "all headings and subheadings", and "show all" states. -*** New option 'outline-minor-mode-highlight'. -This option customizes 'outline-minor-mode'. It puts highlighting -on heading lines using standard outline faces. This works well only -when there are no conflicts with faces used by the major mode. +*** New user option 'outline-minor-mode-highlight'. +This user option customizes 'outline-minor-mode'. It puts +highlighting on heading lines using standard outline faces. This +works well only when there are no conflicts with faces used by the +major mode. * Changes in Specialized Modes and Packages in Emacs 28.1 ** Macroexp --- -*** New function 'macroexp-file-name' to know the name of the current file +*** New function 'macroexp-file-name' to know the name of the current file. --- *** New function 'macroexp-compiling-p' to know if we're compiling. --- @@ -400,17 +401,18 @@ It used to be enabled when Emacs is started in GUI mode but not when started in text mode. The cursor still only actually blinks in GUI frames. ** Bindat + +++ *** New 'Bindat type expression' description language. This new system is provided by the new macro 'bindat-type' and obsoletes the old data layout specifications. It supports arbitrary-size integers, recursive types, and more. See the Info node -'Byte Packing' in the ELisp manual for more details. +"(elisp) Byte Packing" in the ELisp manual for more details. ** pcase +++ -*** The 'or' pattern now binds the union of the vars of its sub-patterns +*** The 'or' pattern now binds the union of the vars of its sub-patterns. If a variable is not bound by the subpattern that matched, it gets bound to nil. This was already sometimes the case, but it is now guaranteed. @@ -1031,10 +1033,9 @@ To customize obsolete user options, use 'customize-option' or ** Edebug ---- *** Obsoletions +--- **** 'get-edebug-spec' is obsolete, replaced by 'edebug-get-spec'. - +++ **** The spec operator ':name NAME' is obsolete, use '&name' instead. +++ @@ -1066,7 +1067,7 @@ use) and HEAD is the code that matched SPEC. +++ *** New user option 'eldoc-echo-area-display-truncation-message'. If non-nil (the default), eldoc will display a message saying -something like "(Documentation truncated. Use `M-x eldoc-doc-buffer' +something like "(Documentation truncated. Use `M-x eldoc-doc-buffer' to see rest)" when a message has been truncated. If nil, truncated messages will be marked with just "..." at the end. @@ -1134,6 +1135,10 @@ preferred over the eudcb-mab.el backend. *** New connection method "mtp", which allows accessing media devices like cell phones, tablets or cameras. ++++ +*** New connection method "sshfs", which allows accessing remote files +via a file system mounted with 'sshfs'. + +++ *** Trashed remote files are moved to the local trash directory. All remote files, which are trashed, are moved to the local trash @@ -1555,7 +1560,7 @@ have been renamed to have "proper" public names and documented 'xref-show-definitions-buffer-at-bottom'). *** New command 'xref-quit-and-pop-marker-stack' and a binding for it -in "*xref*" buffers ('M-,'). This combination is easy to press +in "*xref*" buffers ('M-,'). This combination is easy to press semi-accidentally if the user wants to go back in the middle of choosing the exact definition to go to, and this should do TRT. @@ -2138,7 +2143,7 @@ messages, contain the error name of that message now. +++ *** D-Bus events have changed their internal structure. They carry now the destination and the error-name of an event. They -also keep the type information of their arguments. Use the +also keep the type information of their arguments. Use the 'dbus-event-*' accessor functions. ** CPerl Mode @@ -2180,7 +2185,7 @@ You can type 'C-x u u' instead of 'C-x u C-x u' to undo many changes, 'C-x { { } } ^ ^ v v' to resize the selected window interactively, 'M-g n n p p' to navigate next-error matches. Any other key exits transient mode and then is executed normally. 'repeat-exit-key' -defines an additional key to exit mode like 'isearch-exit' (RET). +defines an additional key to exit mode like 'isearch-exit' ('RET'). * New Modes and Packages in Emacs 28.1 @@ -2296,7 +2301,7 @@ by mistake and were not useful to Lisp code. --- ** Loading 'generic-x' unconditionally loads all modes. -The user option `generic-extras-enable-list' is now obsolete, and +The user option 'generic-extras-enable-list' is now obsolete, and setting it has no effect. --- @@ -2343,8 +2348,8 @@ ledit.el, lmenu.el, lucid.el and old-whitespace.el. 'dirtrack-debug-toggle', 'dynamic-completion-table', 'easy-menu-precalculate-equivalent-keybindings', 'epa-display-verify-result', 'epg-passphrase-callback-function', -'erc-announced-server-name', 'erc-process', -'erc-default-coding-system', 'erc-send-command', 'eshell-report-bug', +'erc-announced-server-name', 'erc-default-coding-system', +'erc-process', 'erc-send-command', 'eshell-report-bug', 'eval-next-after-load', 'exchange-dot-and-mark', 'ffap-bug', 'ffap-submit-bug', 'ffap-version', 'file-cache-choose-completion', 'forward-point', 'generic-char-p', 'global-highlight-changes', @@ -2391,7 +2396,7 @@ ledit.el, lmenu.el, lucid.el and old-whitespace.el. 'semantic-toplevel-bovine-table', 'semanticdb-mode-hooks', 'set-coding-priority', 'set-process-filter-multibyte', 'shadows-compare-text-p', 'shell-dirtrack-toggle', -'speedbar-update-speed', 'speedbar-navigating-speed', 't-mouse-mode', +'speedbar-navigating-speed', 'speedbar-update-speed', 't-mouse-mode', 'term-dynamic-simple-complete', 'tooltip-hook', 'tpu-have-ispell', 'url-generate-unique-filename', 'url-temporary-directory', 'vc-arch-command', 'vc-default-working-revision' (variable), @@ -2413,6 +2418,8 @@ back in Emacs 23.1. The affected functions are: 'make-obsolete', ** The variable 'keyboard-type' is obsolete and not dynamically scoped any more. +** The 'values' variable is now obsolete. + * Lisp Changes in Emacs 28.1 @@ -2449,13 +2456,13 @@ This variable holds a list of currently enabled global minor modes (as a list of symbols). +++ -** 'define-minor-mode' now takes an :interactive argument. +** 'define-minor-mode' now takes an ':interactive' argument. This can be used for specifying which modes this minor mode is meant for, or to make the new minor mode non-interactive. The default value is t. +++ -** 'define-derived-mode' now takes an :interactive argument. +** 'define-derived-mode' now takes an ':interactive' argument. This can be used to control whether the defined mode is a command or not, and is useful when defining commands that aren't meant to be used by users directly. @@ -2463,8 +2470,6 @@ used by users directly. --- ** The 'easymenu' library is now preloaded. -** The 'values' variable is now obsolete. - --- ** New variable 'indent-line-ignored-functions'. This allows modes to cycle through a set of indentation functions @@ -2495,10 +2500,11 @@ When non-nil, then functions 'read-char-choice' and 'y-or-n-p' (respectively) use the function 'read-key' to read a character instead of using the minibuffer. --- -** New variable 'use-short-answers' to use 'y-or-n-p' instead of 'yes-or-no-p'. -This eliminates the need to define an alias that maps one to another -in the init file. The same variable also controls whether the -function 'read-answer' accepts short answers. +** New user option 'use-short-answers'. +When non-nil, the function 'y-or-n-p' is used instead of +'yes-or-no-p'. This eliminates the need to define an alias that maps +one to another in the init file. The same user option also controls +whether the function 'read-answer' accepts short answers. +++ ** 'set-window-configuration' now takes an optional 'dont-set-frame' @@ -2700,7 +2706,7 @@ menu handling. It is meant as an (experimental) aid for converting Emacs Lisp code to lexical binding, where dynamic (special) variables bound in one file can affect code in another. For details, see the manual section -"(Elisp) Converting to Lexical Binding". +"(elisp) Converting to Lexical Binding". +++ *** 'byte-recompile-directory' can now compile symlinked ".el" files. diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el new file mode 100644 index 00000000000..ec1db8680f2 --- /dev/null +++ b/lisp/net/tramp-fuse.el @@ -0,0 +1,205 @@ +;;; tramp-fuse.el --- Tramp access functions for FUSE mounts -*- lexical-binding:t -*- + +;; Copyright (C) 2021 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: + +;; These are helper functions for FUSE file systems. + +;;; Code: + +(require 'tramp) + +;; File name primitives. + +(defun tramp-fuse-handle-delete-directory + (directory &optional recursive trash) + "Like `delete-directory' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name directory) nil + (tramp-flush-directory-properties v localname) + (delete-directory (tramp-fuse-local-file-name directory) recursive trash))) + +(defun tramp-fuse-handle-delete-file (filename &optional trash) + "Like `delete-file' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (delete-file (tramp-fuse-local-file-name filename) trash) + (tramp-flush-file-properties v localname))) + +(defun tramp-fuse-handle-directory-files + (directory &optional full match nosort count) + "Like `directory-files' for Tramp files." + (unless (file-exists-p directory) + (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (when (file-directory-p directory) + (setq directory (file-name-as-directory (expand-file-name directory))) + (with-parsed-tramp-file-name directory nil + (let ((result + (tramp-compat-directory-files + (tramp-fuse-local-file-name directory) full match nosort count))) + ;; Massage the result. + (when full + (let ((local (concat "^" (regexp-quote (tramp-fuse-mount-point v)))) + (remote (directory-file-name + (funcall + (if (tramp-compat-file-name-quoted-p directory) + #'tramp-compat-file-name-quote #'identity) + (file-remote-p directory))))) + (setq result + (mapcar + (lambda (x) (replace-regexp-in-string local remote x)) + result)))) + ;; Some storage systems do not return "." and "..". + (dolist (item '(".." ".")) + (when (and (string-match-p (or match (regexp-quote item)) item) + (not + (member (if full (setq item (concat directory item)) item) + result))) + (setq result (cons item result)))) + ;; Return result. + (if nosort result (sort result #'string<)))))) + +(defun tramp-fuse-handle-file-attributes (filename &optional id-format) + "Like `file-attributes' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property + v localname (format "file-attributes-%s" id-format) + (file-attributes (tramp-fuse-local-file-name filename) id-format)))) + +(defun tramp-fuse-handle-file-executable-p (filename) + "Like `file-executable-p' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property v localname "file-executable-p" + (file-executable-p (tramp-fuse-local-file-name filename))))) + +(defun tramp-fuse-handle-file-name-all-completions (filename directory) + "Like `file-name-all-completions' for Tramp files." + (all-completions + filename + (delete-dups + (append + (file-name-all-completions + filename (tramp-fuse-local-file-name directory)) + ;; Some storage systems do not return "." and "..". + (let (result) + (dolist (item '(".." ".") result) + (when (string-prefix-p filename item) + (catch 'match + (dolist (elt completion-regexp-list) + (unless (string-match-p elt item) (throw 'match nil))) + (setq result (cons (concat item "/") result)))))))))) + +(defun tramp-fuse-handle-file-readable-p (filename) + "Like `file-readable-p' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property v localname "file-readable-p" + (file-readable-p (tramp-fuse-local-file-name filename))))) + +;; This function isn't used. +(defun tramp-fuse-handle-insert-directory + (filename switches &optional wildcard full-directory-p) + "Like `insert-directory' for Tramp files." + (insert-directory + (tramp-fuse-local-file-name filename) switches wildcard full-directory-p) + (goto-char (point-min)) + (while (search-forward (tramp-fuse-local-file-name filename) nil 'noerror) + (replace-match filename))) + +(defun tramp-fuse-handle-make-directory (dir &optional parents) + "Like `make-directory' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name dir) nil + (make-directory (tramp-fuse-local-file-name dir) parents) + ;; When PARENTS is non-nil, DIR could be a chain of non-existent + ;; directories a/b/c/... Instead of checking, we simply flush the + ;; whole file cache. + (tramp-flush-file-properties v localname) + (tramp-flush-directory-properties + v (if parents "/" (file-name-directory localname))))) + + +;; File name helper functions. + +(defun tramp-fuse-mount-spec (vec) + "Return local mount spec of VEC." + (if-let ((host (tramp-file-name-host vec)) + (user (tramp-file-name-user vec))) + (format "%s@%s:/" user host) + (format "%s:/" host))) + +(defun tramp-fuse-mount-point (vec) + "Return local mount point of VEC." + (or (tramp-get-connection-property vec "mount-point" nil) + (expand-file-name + (concat + tramp-temp-name-prefix + (tramp-file-name-method vec) "." + (when (tramp-file-name-user vec) + (concat (tramp-file-name-user-domain vec) "@")) + (tramp-file-name-host-port vec)) + (tramp-compat-temporary-file-directory)))) + +(defun tramp-fuse-mounted-p (vec) + "Check, whether fuse volume determined by VEC is mounted." + (when (tramp-get-connection-process vec) + ;; We cannot use `with-connection-property', because we don't want + ;; to cache a nil result. + (or (tramp-get-connection-property + (tramp-get-connection-process vec) "mounted" nil) + (let* ((default-directory (tramp-compat-temporary-file-directory)) + (fuse (concat "fuse." (tramp-file-name-method vec))) + (mount (shell-command-to-string (format "mount -t %s" fuse)))) + (tramp-message vec 6 "%s %s" "mount -t" fuse) + (tramp-message vec 6 "\n%s" mount) + (tramp-set-connection-property + (tramp-get-connection-process vec) "mounted" + (when (string-match + (format + "^\\(%s\\)\\s-" (regexp-quote (tramp-fuse-mount-spec vec))) + mount) + (match-string 1 mount))))))) + +(defun tramp-fuse-local-file-name (filename) + "Return local mount name of FILENAME." + (setq filename (tramp-compat-file-name-unquote (expand-file-name filename))) + (with-parsed-tramp-file-name filename nil + ;; As long as we call `tramp-*-maybe-open-connection' here, + ;; we cache the result. + (with-tramp-file-property v localname "local-file-name" + (funcall + (intern + (format "tramp-%s-maybe-open-connection" (tramp-file-name-method v))) + v) + (let ((quoted (tramp-compat-file-name-quoted-p localname)) + (localname (tramp-compat-file-name-unquote localname))) + (funcall + (if quoted #'tramp-compat-file-name-quote #'identity) + (expand-file-name + (if (file-name-absolute-p localname) + (substring localname 1) localname) + (tramp-fuse-mount-point v))))))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-fuse 'force))) + +(provide 'tramp-fuse) + +;;; tramp-fuse.el ends here diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index a7f4c9be82c..e6f9fe56ec0 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -35,8 +35,8 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) (require 'tramp) +(require 'tramp-fuse) ;;;###tramp-autoload (defconst tramp-rclone-method "rclone" @@ -77,11 +77,11 @@ ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-handle-copy-directory) (copy-file . tramp-rclone-handle-copy-file) - (delete-directory . tramp-rclone-handle-delete-directory) - (delete-file . tramp-rclone-handle-delete-file) + (delete-directory . tramp-fuse-handle-delete-directory) + (delete-file . tramp-fuse-handle-delete-file) ;; `diff-latest-backup-file' performed by default handler. (directory-file-name . tramp-handle-directory-file-name) - (directory-files . tramp-rclone-handle-directory-files) + (directory-files . tramp-fuse-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) (dired-compress-file . ignore) @@ -90,15 +90,15 @@ (expand-file-name . tramp-handle-expand-file-name) (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . ignore) - (file-attributes . tramp-rclone-handle-file-attributes) + (file-attributes . tramp-fuse-handle-file-attributes) (file-directory-p . tramp-handle-file-directory-p) (file-equal-p . tramp-handle-file-equal-p) - (file-executable-p . tramp-rclone-handle-file-executable-p) + (file-executable-p . tramp-fuse-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-handle-file-local-copy) (file-modes . tramp-handle-file-modes) - (file-name-all-completions . tramp-rclone-handle-file-name-all-completions) + (file-name-all-completions . tramp-fuse-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) (file-name-case-insensitive-p . tramp-handle-file-name-case-insensitive-p) (file-name-completion . tramp-handle-file-name-completion) @@ -110,7 +110,7 @@ (file-notify-rm-watch . ignore) (file-notify-valid-p . ignore) (file-ownership-preserved-p . ignore) - (file-readable-p . tramp-rclone-handle-file-readable-p) + (file-readable-p . tramp-fuse-handle-file-readable-p) (file-regular-p . tramp-handle-file-regular-p) (file-remote-p . tramp-handle-file-remote-p) (file-selinux-context . tramp-handle-file-selinux-context) @@ -124,7 +124,7 @@ (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) - (make-directory . tramp-rclone-handle-make-directory) + (make-directory . tramp-fuse-handle-make-directory) (make-directory-internal . ignore) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) @@ -277,86 +277,6 @@ file names." (list filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes)))) -(defun tramp-rclone-handle-delete-directory - (directory &optional recursive trash) - "Like `delete-directory' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name directory) nil - (tramp-flush-directory-properties v localname) - (delete-directory (tramp-rclone-local-file-name directory) recursive trash))) - -(defun tramp-rclone-handle-delete-file (filename &optional trash) - "Like `delete-file' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (delete-file (tramp-rclone-local-file-name filename) trash) - (tramp-flush-file-properties v localname))) - -(defun tramp-rclone-handle-directory-files - (directory &optional full match nosort count) - "Like `directory-files' for Tramp files." - (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) - (when (file-directory-p directory) - (setq directory (file-name-as-directory (expand-file-name directory))) - (with-parsed-tramp-file-name directory nil - (let ((result - (tramp-compat-directory-files - (tramp-rclone-local-file-name directory) full match nosort count))) - ;; Massage the result. - (when full - (let ((local (concat "^" (regexp-quote (tramp-rclone-mount-point v)))) - (remote (funcall (if (tramp-compat-file-name-quoted-p directory) - #'tramp-compat-file-name-quote #'identity) - (file-remote-p directory)))) - (setq result - (mapcar - (lambda (x) (replace-regexp-in-string local remote x)) - result)))) - ;; Some storage systems do not return "." and "..". - (dolist (item '(".." ".")) - (when (and (string-match-p (or match (regexp-quote item)) item) - (not - (member (if full (setq item (concat directory item)) item) - result))) - (setq result (cons item result)))) - ;; Return result. - (if nosort result (sort result #'string<)))))) - -(defun tramp-rclone-handle-file-attributes (filename &optional id-format) - "Like `file-attributes' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property - v localname (format "file-attributes-%s" id-format) - (file-attributes (tramp-rclone-local-file-name filename) id-format)))) - -(defun tramp-rclone-handle-file-executable-p (filename) - "Like `file-executable-p' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property v localname "file-executable-p" - (file-executable-p (tramp-rclone-local-file-name filename))))) - -(defun tramp-rclone-handle-file-name-all-completions (filename directory) - "Like `file-name-all-completions' for Tramp files." - (all-completions - filename - (delete-dups - (append - (file-name-all-completions - filename (tramp-rclone-local-file-name directory)) - ;; Some storage systems do not return "." and "..". - (let (result) - (dolist (item '(".." ".") result) - (when (string-prefix-p filename item) - (catch 'match - (dolist (elt completion-regexp-list) - (unless (string-match-p elt item) (throw 'match nil))) - (setq result (cons (concat item "/") result)))))))))) - -(defun tramp-rclone-handle-file-readable-p (filename) - "Like `file-readable-p' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property v localname "file-readable-p" - (file-readable-p (tramp-rclone-local-file-name filename))))) - (defun tramp-rclone-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." (ignore-errors @@ -384,36 +304,6 @@ file names." (when (and total free) (list total free (- total free)))))))) -(defun tramp-rclone-handle-insert-directory - (filename switches &optional wildcard full-directory-p) - "Like `insert-directory' for Tramp files." - (insert-directory - (tramp-rclone-local-file-name filename) switches wildcard full-directory-p) - (goto-char (point-min)) - (while (search-forward (tramp-rclone-local-file-name filename) nil 'noerror) - (replace-match filename))) - -(defun tramp-rclone-handle-insert-file-contents - (filename &optional visit beg end replace) - "Like `insert-file-contents' for Tramp files." - (let ((result - (insert-file-contents - (tramp-rclone-local-file-name filename) visit beg end replace))) - (prog1 - (list (expand-file-name filename) (cadr result)) - (when visit (setq buffer-file-name filename))))) - -(defun tramp-rclone-handle-make-directory (dir &optional parents) - "Like `make-directory' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name dir) nil - (make-directory (tramp-rclone-local-file-name dir) parents) - ;; When PARENTS is non-nil, DIR could be a chain of non-existent - ;; directories a/b/c/... Instead of checking, we simply flush the - ;; whole file cache. - (tramp-flush-file-properties v localname) - (tramp-flush-directory-properties - v (if parents "/" (file-name-directory localname))))) - (defun tramp-rclone-handle-rename-file (filename newname &optional ok-if-already-exists) "Like `rename-file' for Tramp files." @@ -431,50 +321,6 @@ file names." ;; File name conversions. -(defun tramp-rclone-mount-point (vec) - "Return local mount point of VEC." - (expand-file-name - (concat - tramp-temp-name-prefix (tramp-file-name-method vec) - "." (tramp-file-name-host vec)) - (tramp-compat-temporary-file-directory))) - -(defun tramp-rclone-mounted-p (vec) - "Check, whether storage system determined by VEC is mounted." - (when (tramp-get-connection-process vec) - ;; We cannot use `with-connection-property', because we don't want - ;; to cache a nil result. - (or (tramp-get-connection-property - (tramp-get-connection-process vec) "mounted" nil) - (let* ((default-directory (tramp-compat-temporary-file-directory)) - (mount (shell-command-to-string "mount -t fuse.rclone"))) - (tramp-message vec 6 "%s" "mount -t fuse.rclone") - (tramp-message vec 6 "\n%s" mount) - (tramp-set-connection-property - (tramp-get-connection-process vec) "mounted" - (when (string-match - (format - "^\\(%s:\\S-*\\)" (regexp-quote (tramp-file-name-host vec))) - mount) - (match-string 1 mount))))))) - -(defun tramp-rclone-local-file-name (filename) - "Return local mount name of FILENAME." - (setq filename (tramp-compat-file-name-unquote (expand-file-name filename))) - (with-parsed-tramp-file-name filename nil - ;; As long as we call `tramp-rclone-maybe-open-connection' here, - ;; we cache the result. - (with-tramp-file-property v localname "local-file-name" - (tramp-rclone-maybe-open-connection v) - (let ((quoted (tramp-compat-file-name-quoted-p localname)) - (localname (tramp-compat-file-name-unquote localname))) - (funcall - (if quoted #'tramp-compat-file-name-quote #'identity) - (expand-file-name - (if (file-name-absolute-p localname) - (substring localname 1) localname) - (tramp-rclone-mount-point v))))))) - (defun tramp-rclone-remote-file-name (filename) "Return FILENAME as used in the `rclone' command." (setq filename (tramp-compat-file-name-unquote (expand-file-name filename))) @@ -487,7 +333,7 @@ file names." ;; TODO: This shall be handled by `expand-file-name'. (setq localname (replace-regexp-in-string "^\\." "" (or localname ""))) - (format "%s%s" (tramp-rclone-mounted-p v) localname))) + (format "%s%s" (tramp-fuse-mounted-p v) localname))) ;; It is a local file name. filename)) @@ -517,20 +363,18 @@ connection if a previous connection has died for some reason." (tramp-set-connection-local-variables vec))) ;; Create directory. - (unless (file-directory-p (tramp-rclone-mount-point vec)) - (make-directory (tramp-rclone-mount-point vec) 'parents)) + (unless (file-directory-p (tramp-fuse-mount-point vec)) + (make-directory (tramp-fuse-mount-point vec) 'parents)) ;; Mount. This command does not return, so we use 0 as ;; DESTINATION of `tramp-call-process'. - (unless (tramp-rclone-mounted-p vec) + (unless (tramp-fuse-mounted-p vec) (apply #'tramp-call-process vec tramp-rclone-program nil 0 nil - (delq nil - `("mount" ,(concat host ":/") - ,(tramp-rclone-mount-point vec) - ;; This could be nil. - ,@(tramp-get-method-parameter vec 'tramp-mount-args)))) + "mount" (tramp-fuse-mount-spec vec) + (tramp-fuse-mount-point vec) + (tramp-get-method-parameter vec 'tramp-mount-args)) (while (not (file-exists-p (tramp-make-tramp-file-name vec 'noloc))) (tramp-cleanup-connection vec 'keep-debug 'keep-password)) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 57301994074..dac83b82a82 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2397,7 +2397,7 @@ The method used must be an out-of-band method." (append copy-args (let ((y (mapcar (lambda (z) (format-spec z spec)) x))) - (if (member "" y) '(" ") y)))))) + (unless (member "" y) y)))))) copy-env (delq @@ -2416,7 +2416,7 @@ The method used must be an out-of-band method." (append remote-copy-args (let ((y (mapcar (lambda (z) (format-spec z spec)) x))) - (if (member "" y) '(" ") y))))) + (unless (member "" y) y))))) ;; Check for local copy program. (unless (executable-find copy-program) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el new file mode 100644 index 00000000000..feb64b82bc7 --- /dev/null +++ b/lisp/net/tramp-sshfs.el @@ -0,0 +1,318 @@ +;;; tramp-sshfs.el --- Tramp access functions via sshfs -*- lexical-binding:t -*- + +;; Copyright (C) 2021 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: + +;; sshfs is a program to mount a virtual file system, based on an sftp +;; connection. Tramp uses its mount utility to access files and +;; directories there. + +;; A remote file under sshfs control has the form +;; "/sshfs:user@host#port:/path/to/file". User name and port number +;; are optional. + +;;; Code: + +(require 'tramp) +(require 'tramp-fuse) + +;;;###tramp-autoload +(defconst tramp-sshfs-method "sshfs" + "Tramp method for sshfs mounts.") + +;;;###tramp-autoload +(defcustom tramp-sshfs-program "sshfs" + "The sshfs mount command." + :group 'tramp + :version "28.1" + :type 'string) + +;;;###tramp-autoload +(tramp--with-startup + (add-to-list 'tramp-methods + `(,tramp-sshfs-method + (tramp-mount-args + (("-p" "%p") + ("-o" "idmap=user,reconnect"))))) + + (tramp-set-completion-function + tramp-sshfs-method tramp-completion-function-alist-ssh)) + + +;; New handlers should be added here. +;;;###tramp-autoload +(defconst tramp-sshfs-file-name-handler-alist + '((access-file . tramp-handle-access-file) + (add-name-to-file . tramp-handle-add-name-to-file) + ;; `byte-compiler-base-file-name' performed by default handler. + (copy-directory . tramp-handle-copy-directory) + (copy-file . tramp-sshfs-handle-copy-file) + (delete-directory . tramp-fuse-handle-delete-directory) + (delete-file . tramp-fuse-handle-delete-file) + ;; `diff-latest-backup-file' performed by default handler. + (directory-file-name . tramp-handle-directory-file-name) + (directory-files . tramp-fuse-handle-directory-files) + (directory-files-and-attributes + . tramp-handle-directory-files-and-attributes) + (dired-compress-file . ignore) + (dired-uncache . tramp-handle-dired-uncache) +;; (exec-path . ignore) + (expand-file-name . tramp-handle-expand-file-name) + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) + (file-acl . ignore) + (file-attributes . tramp-fuse-handle-file-attributes) + (file-directory-p . tramp-handle-file-directory-p) + (file-equal-p . tramp-handle-file-equal-p) + (file-executable-p . tramp-fuse-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-handle-file-local-copy) + (file-modes . tramp-handle-file-modes) + (file-name-all-completions . tramp-fuse-handle-file-name-all-completions) + (file-name-as-directory . tramp-handle-file-name-as-directory) + (file-name-case-insensitive-p . tramp-handle-file-name-case-insensitive-p) + (file-name-completion . tramp-handle-file-name-completion) + (file-name-directory . tramp-handle-file-name-directory) + (file-name-nondirectory . tramp-handle-file-name-nondirectory) + ;; `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-fuse-handle-file-readable-p) + (file-regular-p . tramp-handle-file-regular-p) + (file-remote-p . tramp-handle-file-remote-p) + (file-selinux-context . tramp-handle-file-selinux-context) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-system-info . tramp-sshfs-handle-file-system-info) + (file-truename . tramp-handle-file-truename) + (file-writable-p . tramp-handle-file-writable-p) + (find-backup-file-name . tramp-handle-find-backup-file-name) + ;; `get-file-buffer' performed by default handler. + (insert-directory . tramp-handle-insert-directory) + (insert-file-contents . tramp-sshfs-handle-insert-file-contents) + (load . tramp-handle-load) + (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) + (make-directory . tramp-fuse-handle-make-directory) + (make-directory-internal . ignore) + (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) +;; (make-process . ignore) + (make-symbolic-link . tramp-handle-make-symbolic-link) +;; (process-file . ignore) + (rename-file . tramp-sshfs-handle-rename-file) + (set-file-acl . ignore) + (set-file-modes . ignore) + (set-file-selinux-context . ignore) + (set-file-times . ignore) + (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) +;; (shell-command . ignore) +;; (start-file-process . ignore) + (substitute-in-file-name . tramp-handle-substitute-in-file-name) + (temporary-file-directory . tramp-handle-temporary-file-directory) +;; (tramp-get-remote-gid . ignore) +;; (tramp-get-remote-uid . ignore) +;; (tramp-set-file-uid-gid . ignore) + (unhandled-file-name-directory . ignore) + (vc-registered . ignore) + (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (write-region . tramp-sshfs-handle-write-region)) +"Alist of handler functions for Tramp SSHFS method. +Operations not mentioned here will be handled by the default Emacs primitives.") + +;; It must be a `defsubst' in order to push the whole code into +;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. +;;;###tramp-autoload +(defsubst tramp-sshfs-file-name-p (filename) + "Check if it's a FILENAME for sshfs." + (and (tramp-tramp-file-p filename) + (string= (tramp-file-name-method (tramp-dissect-file-name filename)) + tramp-sshfs-method))) + +;;;###tramp-autoload +(defun tramp-sshfs-file-name-handler (operation &rest args) + "Invoke the sshfs handler for OPERATION and ARGS. +First arg specifies the OPERATION, second arg is a list of +arguments to pass to the OPERATION." + (if-let ((fn (assoc operation tramp-sshfs-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) + +;;;###tramp-autoload +(tramp--with-startup + (tramp-register-foreign-file-name-handler + #'tramp-sshfs-file-name-p #'tramp-sshfs-file-name-handler)) + + +;; File name primitives. + +(defun tramp-sshfs-handle-copy-file + (filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Like `copy-file' for Tramp files." + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) + (if (file-directory-p filename) + (copy-directory filename newname keep-date t) + (copy-file + (if (tramp-sshfs-file-name-p filename) + (tramp-fuse-local-file-name filename) filename) + (if (tramp-sshfs-file-name-p newname) + (tramp-fuse-local-file-name newname) newname) + ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + (when (tramp-sshfs-file-name-p newname) + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-properties v localname))))) + +(defun tramp-sshfs-handle-file-system-info (filename) + "Like `file-system-info' for Tramp files." + ;;`file-system-info' exists since Emacs 27.1. + (tramp-compat-funcall 'file-system-info (tramp-fuse-local-file-name filename))) + +(defun tramp-sshfs-handle-insert-file-contents + (filename &optional visit beg end replace) + "Like `insert-file-contents' for Tramp files." + (let ((result + (insert-file-contents + (tramp-fuse-local-file-name filename) visit beg end replace))) + (when visit (setq buffer-file-name filename)) + (cons (expand-file-name filename) (cdr result)))) + +(defun tramp-sshfs-handle-rename-file + (filename newname &optional ok-if-already-exists) + "Like `rename-file' for Tramp files." + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) + (rename-file + (if (tramp-sshfs-file-name-p filename) + (tramp-fuse-local-file-name filename) filename) + (if (tramp-sshfs-file-name-p newname) + (tramp-fuse-local-file-name newname) newname) + ok-if-already-exists) + (when (tramp-sshfs-file-name-p filename) + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v localname))) + (when (tramp-sshfs-file-name-p newname) + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-properties v localname)))) + +(defun tramp-sshfs-handle-write-region + (start end filename &optional append visit lockname mustbenew) + "Like `write-region' for Tramp files." + (setq filename (expand-file-name filename)) + (with-parsed-tramp-file-name filename nil + (when (and mustbenew (file-exists-p filename) + (or (eq mustbenew 'excl) + (not + (y-or-n-p + (format "File %s exists; overwrite anyway? " filename))))) + (tramp-error v 'file-already-exists filename)) + + (write-region + start end (tramp-fuse-local-file-name filename) append 'nomessage lockname) + (tramp-flush-file-properties v localname) + + ;; The end. + (when (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) + (tramp-message v 0 "Wrote %s" filename)) + (run-hooks 'tramp-handle-write-region-hook))) + + +;; File name conversions. + +(defun tramp-sshfs-maybe-open-connection (vec) + "Maybe open a connection VEC. +Does not do anything if a connection is already open, but re-opens the +connection if a previous connection has died for some reason." + ;; During completion, don't reopen a new connection. + (unless (tramp-connectable-p vec) + (throw 'non-essential 'non-essential)) + + ;; We need a process bound to the connection buffer. Therefore, we + ;; create a dummy process. Maybe there is a better solution? + (unless (get-buffer-process (tramp-get-connection-buffer vec)) + (let ((p (make-network-process + :name (tramp-get-connection-name vec) + :buffer (tramp-get-connection-buffer vec) + :server t :host 'local :service t :noquery t))) + (process-put p 'vector vec) + (set-process-query-on-exit-flag p nil) + + ;; Set connection-local variables. + (tramp-set-connection-local-variables vec) + + ;; Create directory. + (unless (file-directory-p (tramp-fuse-mount-point vec)) + (make-directory (tramp-fuse-mount-point vec) 'parents)) + + (unless + (or (tramp-fuse-mounted-p vec) + (let* ((port (or (tramp-file-name-port vec) "")) + (spec (format-spec-make ?p port)) + mount-args + (mount-args + (dolist + (x + (tramp-get-method-parameter vec 'tramp-mount-args) + mount-args) + (setq mount-args + (append + mount-args + (let ((y (mapcar + (lambda (z) (format-spec z spec)) + x))) + (unless (member "" y) y))))))) + (with-temp-buffer + (zerop + (apply + #'tramp-call-process + vec tramp-sshfs-program nil t nil + (tramp-fuse-mount-spec vec) + (tramp-fuse-mount-point vec) mount-args)))) + (tramp-error + vec 'file-error "Error mounting %s" (tramp-fuse-mount-spec vec)))) + + ;; Mark it as connected. + (tramp-set-connection-property + (tramp-get-connection-process vec) "connected" t))) + + ;; In `tramp-check-cached-permissions', the connection properties + ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. + (with-tramp-connection-property + vec "uid-integer" (tramp-get-local-uid 'integer)) + (with-tramp-connection-property + vec "gid-integer" (tramp-get-local-gid 'integer)) + (with-tramp-connection-property + vec "uid-string" (tramp-get-local-uid 'string)) + (with-tramp-connection-property + vec "gid-string" (tramp-get-local-gid 'string))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-sshfs 'force))) + +(provide 'tramp-sshfs) + +;;; tramp-sshfs.el ends here diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 14d5f8c3b6b..47d62f38045 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -5447,11 +5447,6 @@ BODY is the backend specific code." ;; strange when doing zerop, we should kill the process and start ;; again. (Greg Stark) ;; -;; * I was wondering if it would be possible to use tramp even if I'm -;; actually using sshfs. But when I launch a command I would like -;; to get it executed on the remote machine where the files really -;; are. (Andrea Crotti) -;; ;; * Run emerge on two remote files. Bug is described here: ;; . ;; (Bug#6850) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 016b4d3c8f0..d9a8065e723 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2824,9 +2824,10 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (should (file-exists-p (expand-file-name "bla" tmp-name2))) (should-error (delete-directory tmp-name1 nil 'trash) - ;; tramp-rclone.el calls the local `delete-directory'. - ;; This raises another error. - :type (if (tramp--test-rclone-p) 'error 'file-error)) + ;; tramp-rclone.el and tramp-sshfs.el call the local + ;; `delete-directory'. This raises another error. + :type (if (or (tramp--test-rclone-p) (tramp--test-sshfs-p)) + 'error 'file-error)) (delete-directory tmp-name1 'recursive 'trash) (should-not (file-directory-p tmp-name1)) (should @@ -3254,8 +3255,8 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (ignore-errors (delete-directory tmp-name1 'recursive)))))) ;; Method "smb" supports `make-symbolic-link' only if the remote host -;; has CIFS capabilities. tramp-adb.el, tramp-gvfs.el and -;; tramp-rclone.el do not support symbolic links at all. +;; has CIFS capabilities. tramp-adb.el, tramp-gvfs.el, tramp-rclone.el +;; and tramp-sshfs.el do not support symbolic links at all. (defmacro tramp--test-ignore-make-symbolic-link-error (&rest body) "Run BODY, ignoring \"make-symbolic-link not supported\" file error." (declare (indent defun) (debug (body))) @@ -5819,6 +5820,11 @@ Additionally, ls does not support \"--dired\"." "^\\(afp\\|davs?\\|smb\\)$" (file-remote-p tramp-test-temporary-file-directory 'method)))) +(defun tramp--test-sshfs-p () + "Check, whether the remote host is offered by sshfs. +This requires restrictions of file name syntax." + (tramp-sshfs-file-name-p tramp-test-temporary-file-directory)) + (defun tramp--test-sudoedit-p () "Check, whether the sudoedit method is used." (tramp-sudoedit-file-name-p tramp-test-temporary-file-directory)) @@ -6761,7 +6767,6 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; * Fix `tramp-test06-directory-file-name' for `ftp'. ;; * Implement `tramp-test31-interrupt-process' for `adb' and for ;; direct async processes. -;; * Fix `tramp-test44-threads'. (provide 'tramp-tests) -- cgit v1.2.3 From dc083ebc4e34158b3be4c16d558d104c8c4e5c77 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 8 Mar 2021 10:11:22 -0500 Subject: * lisp/net/*.el: Use lexical-binding Also remove some redundant `:group` arguments. * lisp/net/eudc-export.el: Use lexical-binding. (eudc-create-bbdb-record): Use `cl-progv` and `apply` to avoid `eval`. * lisp/net/eudc-hotlist.el: Use lexical-binding. * lisp/net/eudc.el (eudc-print-attribute-value): Use `funcall` to avoid `eval`. * lisp/net/eudcb-bbdb.el: Use lexical-binding. (eudc-bbdb-filter-non-matching-record): Use `funcall` to avoid `eval`. Move `bbdb-val` binding to avoid `setq`. Use `seq-some` instead of `eval+or`. (eudc-bbdb-format-record-as-result): Use `dolist` and `pcase`. Use `funcall` to avoid `eval`. (eudc-bbdb-query-internal): Simplify a bit. * lisp/net/eudcb-ldap.el: Use lexical-binding. (eudc-ldap-get-host-parameter): Use `defalias` to avoid `eval-and-compile`. * lisp/net/telnet.el: Use lexical-binding. * lisp/net/quickurl.el: Use lexical-binding. * lisp/net/newst-ticker.el: Use lexical-binding. * lisp/net/newst-reader.el: Use lexical-binding. * lisp/net/goto-addr.el: Use lexical-binding. * lisp/net/gnutls.el: Use lexical-binding. * lisp/net/eudcb-macos-contacts.el: Use lexical-binding. * lisp/net/eudcb-mab.el: Use lexical-binding. * lisp/net/net-utils.el: Use lexical-binding. (finger): Remove unused var `found`. * lisp/net/network-stream.el (open-protocol-stream): Remove redundant `defalias`. * lisp/net/newst-plainview.el: Use lexical-binding. (newsticker-hide-entry, newsticker-show-entry): Remove unused var `is-invisible`. (w3m-fill-column, w3-maximum-line-length): Declare vars. * lisp/net/tramp.el (tramp-compute-multi-hops): * lisp/net/tramp-compat.el (tramp-compat-temporary-file-directory): * lisp/net/tramp-cmds.el (tramp-default-rename-file): * lisp/net/webjump.el (webjump): Don't forget lexical-binding for `eval`. --- lisp/net/browse-url.el | 42 ++++++------- lisp/net/dictionary.el | 67 ++++++++++---------- lisp/net/dig.el | 4 +- lisp/net/dns.el | 8 +-- lisp/net/eudc-bob.el | 20 +++--- lisp/net/eudc-export.el | 78 +++++++++++------------ lisp/net/eudc-hotlist.el | 14 ++--- lisp/net/eudc.el | 14 ++--- lisp/net/eudcb-bbdb.el | 125 ++++++++++++++++++------------------- lisp/net/eudcb-ldap.el | 18 +++--- lisp/net/eudcb-mab.el | 2 +- lisp/net/eudcb-macos-contacts.el | 4 +- lisp/net/gnutls.el | 7 +-- lisp/net/goto-addr.el | 28 +++------ lisp/net/net-utils.el | 84 ++++++++----------------- lisp/net/network-stream.el | 3 +- lisp/net/newst-backend.el | 32 +++++----- lisp/net/newst-plainview.el | 121 ++++++++++++++++++------------------ lisp/net/newst-reader.el | 10 +-- lisp/net/newst-ticker.el | 12 ++-- lisp/net/newst-treeview.el | 129 ++++++++++++++++++--------------------- lisp/net/puny.el | 4 +- lisp/net/quickurl.el | 29 +++------ lisp/net/rcirc.el | 2 +- lisp/net/secrets.el | 10 +-- lisp/net/shr-color.el | 14 ++--- lisp/net/shr.el | 26 ++++---- lisp/net/sieve-mode.el | 6 +- lisp/net/soap-client.el | 26 ++++---- lisp/net/soap-inspect.el | 46 +++++++------- lisp/net/telnet.el | 20 +++--- lisp/net/tramp-cmds.el | 2 +- lisp/net/tramp-compat.el | 2 +- lisp/net/tramp-integration.el | 2 +- lisp/net/tramp-sh.el | 4 +- lisp/net/tramp.el | 25 ++++++-- lisp/net/webjump.el | 2 +- 37 files changed, 489 insertions(+), 553 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 58f01d5bf98..1c98335a20c 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -826,7 +826,7 @@ If optional arg TEMP-FILE-NAME is non-nil, delete it instead." (if (and file-name (file-exists-p file-name)) (delete-file file-name)))) -(add-hook 'kill-buffer-hook 'browse-url-delete-temp-file) +(add-hook 'kill-buffer-hook #'browse-url-delete-temp-file) (declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep)) @@ -1064,7 +1064,7 @@ xdg-open is a desktop utility that calls your preferred web browser." (executable-find "xdg-open"))) ;;;###autoload -(defun browse-url-xdg-open (url &optional ignored) +(defun browse-url-xdg-open (url &optional _ignored) "Pass the specified URL to the \"xdg-open\" command. xdg-open is a desktop utility that calls your preferred web browser. The optional argument IGNORED is not used." @@ -1095,7 +1095,7 @@ used instead of `browse-url-new-window-flag'." (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment)) (process - (apply 'start-process + (apply #'start-process (concat "netscape " url) nil browse-url-netscape-program (append @@ -1125,7 +1125,7 @@ used instead of `browse-url-new-window-flag'." (let* ((process-environment (browse-url-process-environment))) ;; Netscape not running - start it (message "Starting %s..." browse-url-netscape-program) - (apply 'start-process (concat "netscape" url) nil + (apply #'start-process (concat "netscape" url) nil browse-url-netscape-program (append browse-url-netscape-startup-arguments (list url)))))) @@ -1144,7 +1144,7 @@ How depends on `browse-url-netscape-version'." "Send a remote control command to Netscape." (declare (obsolete nil "25.1")) (let* ((process-environment (browse-url-process-environment))) - (apply 'start-process "netscape" nil + (apply #'start-process "netscape" nil browse-url-netscape-program (append browse-url-netscape-arguments (list "-remote" command))))) @@ -1170,7 +1170,7 @@ used instead of `browse-url-new-window-flag'." (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment)) (process - (apply 'start-process + (apply #'start-process (concat "mozilla " url) nil browse-url-mozilla-program (append @@ -1196,7 +1196,7 @@ used instead of `browse-url-new-window-flag'." (let* ((process-environment (browse-url-process-environment))) ;; Mozilla is not running - start it (message "Starting %s..." browse-url-mozilla-program) - (apply 'start-process (concat "mozilla " url) nil + (apply #'start-process (concat "mozilla " url) nil browse-url-mozilla-program (append browse-url-mozilla-startup-arguments (list url)))))) @@ -1219,7 +1219,7 @@ instead of `browse-url-new-window-flag'." (interactive (browse-url-interactive-arg "URL: ")) (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment))) - (apply 'start-process + (apply #'start-process (concat "firefox " url) nil browse-url-firefox-program (append @@ -1242,7 +1242,7 @@ The optional argument NEW-WINDOW is not used." (interactive (browse-url-interactive-arg "URL: ")) (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment))) - (apply 'start-process + (apply #'start-process (concat "chromium " url) nil browse-url-chromium-program (append @@ -1260,7 +1260,7 @@ The optional argument NEW-WINDOW is not used." (interactive (browse-url-interactive-arg "URL: ")) (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment))) - (apply 'start-process + (apply #'start-process (concat "google-chrome " url) nil browse-url-chrome-program (append @@ -1290,7 +1290,7 @@ used instead of `browse-url-new-window-flag'." (interactive (browse-url-interactive-arg "URL: ")) (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment)) - (process (apply 'start-process + (process (apply #'start-process (concat "galeon " url) nil browse-url-galeon-program @@ -1315,7 +1315,7 @@ used instead of `browse-url-new-window-flag'." (let* ((process-environment (browse-url-process-environment))) ;; Galeon is not running - start it (message "Starting %s..." browse-url-galeon-program) - (apply 'start-process (concat "galeon " url) nil + (apply #'start-process (concat "galeon " url) nil browse-url-galeon-program (append browse-url-galeon-startup-arguments (list url)))))) @@ -1338,7 +1338,7 @@ used instead of `browse-url-new-window-flag'." (interactive (browse-url-interactive-arg "URL: ")) (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment)) - (process (apply 'start-process + (process (apply #'start-process (concat "epiphany " url) nil browse-url-epiphany-program @@ -1362,7 +1362,7 @@ used instead of `browse-url-new-window-flag'." (let* ((process-environment (browse-url-process-environment))) ;; Epiphany is not running - start it (message "Starting %s..." browse-url-epiphany-program) - (apply 'start-process (concat "epiphany " url) nil + (apply #'start-process (concat "epiphany " url) nil browse-url-epiphany-program (append browse-url-epiphany-startup-arguments (list url)))))) @@ -1403,7 +1403,7 @@ When called non-interactively, optional second argument NEW-WINDOW is used instead of `browse-url-new-window-flag'." (declare (obsolete nil "25.1")) (interactive (browse-url-interactive-arg "URL: ")) - (apply 'start-process (concat "gnome-moz-remote " url) + (apply #'start-process (concat "gnome-moz-remote " url) nil browse-url-gnome-moz-program (append @@ -1437,7 +1437,7 @@ NEW-WINDOW instead of `browse-url-new-window-flag'." (interactive (browse-url-interactive-arg "URL: ")) (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment))) - (apply 'start-process (format "conkeror %s" url) + (apply #'start-process (format "conkeror %s" url) nil browse-url-conkeror-program (append @@ -1487,7 +1487,7 @@ The `browse-url-gnudoit-program' program is used with options given by `browse-url-gnudoit-args'. Default to the URL around or before point." (declare (obsolete nil "25.1")) (interactive (browse-url-interactive-arg "W3 URL: ")) - (apply 'start-process (concat "gnudoit:" url) nil + (apply #'start-process (concat "gnudoit:" url) nil browse-url-gnudoit-program (append browse-url-gnudoit-args (list (concat "(w3-fetch \"" url "\")") @@ -1667,7 +1667,7 @@ don't offer a form of remote control." (interactive (browse-url-interactive-arg "URL: ")) (if (not browse-url-generic-program) (error "No browser defined (`browse-url-generic-program')")) - (apply 'call-process browse-url-generic-program nil + (apply #'call-process browse-url-generic-program nil 0 nil (append browse-url-generic-args (list url)))) @@ -1742,9 +1742,9 @@ from `browse-url-elinks-wrapper'." (defvar browse-url-button-map (let ((map (make-sparse-keymap))) - (define-key map "\r" 'browse-url-button-open) - (define-key map [mouse-2] 'browse-url-button-open) - (define-key map "w" 'browse-url-button-copy) + (define-key map "\r" #'browse-url-button-open) + (define-key map [mouse-2] #'browse-url-button-open) + (define-key map "w" #'browse-url-button-copy) map) "The keymap used for browse-url buttons.") diff --git a/lisp/net/dictionary.el b/lisp/net/dictionary.el index aba3698a533..5148a66724b 100644 --- a/lisp/net/dictionary.el +++ b/lisp/net/dictionary.el @@ -76,7 +76,7 @@ You can specify here: - dict.org: Only use dict.org - User-defined: You can specify your own server here" :group 'dictionary - :set 'dictionary-set-server-var + :set #'dictionary-set-server-var :type '(choice (const :tag "Automatic" nil) (const :tag "localhost" "localhost") (const :tag "dict.org" "dict.org") @@ -88,7 +88,7 @@ You can specify here: "The port of the dictionary server. This port is propably always 2628 so there should be no need to modify it." :group 'dictionary - :set 'dictionary-set-server-var + :set #'dictionary-set-server-var :type 'number :version "28.1") @@ -189,7 +189,7 @@ where the current word was found." nil "Connects via a HTTP proxy using the CONNECT command when not nil." :group 'dictionary-proxy - :set 'dictionary-set-server-var + :set #'dictionary-set-server-var :type 'boolean :version "28.1") @@ -197,7 +197,7 @@ where the current word was found." "proxy" "The name of the HTTP proxy to use when `dictionary-use-http-proxy' is set." :group 'dictionary-proxy - :set 'dictionary-set-server-var + :set #'dictionary-set-server-var :type 'string :version "28.1") @@ -205,7 +205,7 @@ where the current word was found." 3128 "The port of the proxy server, used only when `dictionary-use-http-proxy' is set." :group 'dictionary-proxy - :set 'dictionary-set-server-var + :set #'dictionary-set-server-var :type 'number :version "28.1") @@ -331,19 +331,19 @@ is utf-8" (suppress-keymap map) (set-keymap-parent map button-buffer-map) - (define-key map "q" 'dictionary-close) - (define-key map "h" 'dictionary-help) - (define-key map "s" 'dictionary-search) - (define-key map "d" 'dictionary-lookup-definition) - (define-key map "D" 'dictionary-select-dictionary) - (define-key map "M" 'dictionary-select-strategy) - (define-key map "m" 'dictionary-match-words) - (define-key map "l" 'dictionary-previous) - (define-key map "n" 'forward-button) - (define-key map "p" 'backward-button) - (define-key map " " 'scroll-up-command) - (define-key map [?\S-\ ] 'scroll-down-command) - (define-key map (read-kbd-macro "M-SPC") 'scroll-down-command) + (define-key map "q" #'dictionary-close) + (define-key map "h" #'dictionary-help) + (define-key map "s" #'dictionary-search) + (define-key map "d" #'dictionary-lookup-definition) + (define-key map "D" #'dictionary-select-dictionary) + (define-key map "M" #'dictionary-select-strategy) + (define-key map "m" #'dictionary-match-words) + (define-key map "l" #'dictionary-previous) + (define-key map "n" #'forward-button) + (define-key map "p" #'backward-button) + (define-key map " " #'scroll-up-command) + (define-key map [?\S-\ ] #'scroll-down-command) + (define-key map (read-kbd-macro "M-SPC") #'scroll-down-command) map) "Keymap for the dictionary mode.") @@ -413,7 +413,7 @@ This is a quick reference to this mode describing the default key bindings: (make-local-variable 'dictionary-default-dictionary) (make-local-variable 'dictionary-default-strategy) - (add-hook 'kill-buffer-hook 'dictionary-close t t) + (add-hook 'kill-buffer-hook #'dictionary-close t t) (run-hooks 'dictionary-mode-hook)) ;;;###autoload @@ -535,7 +535,7 @@ The connection takes the proxy setting in customization group ;; Dealing with closing the buffer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun dictionary-close (&rest ignored) +(defun dictionary-close (&rest _ignored) "Close the current dictionary buffer and its connection." (interactive) (if (eq major-mode 'dictionary-mode) @@ -669,7 +669,7 @@ previous state." (setq dictionary-positions (cons (point) (window-start)))) ;; Restore the previous state -(defun dictionary-restore-state (&rest ignored) +(defun dictionary-restore-state (&rest _ignored) "Restore the state just before the last operation." (let ((position (pop dictionary-position-stack)) (data (pop dictionary-data-stack))) @@ -872,7 +872,7 @@ The word is taken from the buffer, the DICTIONARY is given as argument." 'help-echo (concat "Press Mouse-2 to lookup \"" word "\" in \"" dictionary "\""))))) -(defun dictionary-select-dictionary (&rest ignored) +(defun dictionary-select-dictionary (&rest _ignored) "Save the current state and start a dictionary selection." (interactive) (dictionary-ensure-buffer) @@ -880,7 +880,7 @@ The word is taken from the buffer, the DICTIONARY is given as argument." (dictionary-do-select-dictionary) (dictionary-store-state 'dictionary-do-select-dictionary nil)) -(defun dictionary-do-select-dictionary (&rest ignored) +(defun dictionary-do-select-dictionary (&rest _ignored) "The workhorse for doing the dictionary selection." (message "Looking up databases and descriptions") @@ -916,7 +916,7 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (dictionary-display-dictionary-line "! \"The first matching dictionary\"") (let* ((reply (dictionary-read-answer)) (list (dictionary-simple-split-string reply "\n+"))) - (mapc 'dictionary-display-dictionary-line list)) + (mapc #'dictionary-display-dictionary-line list)) (dictionary-post-buffer)) (defun dictionary-display-dictionary-line (string) @@ -984,7 +984,7 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (dictionary-store-state 'dictionary-display-more-info dictionary)))) -(defun dictionary-select-strategy (&rest ignored) +(defun dictionary-select-strategy (&rest _ignored) "Save the current state and start a strategy selection." (interactive) (dictionary-ensure-buffer) @@ -1014,7 +1014,7 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (dictionary-display-strategy-line ". \"The servers default\"") (let* ((reply (dictionary-read-answer)) (list (dictionary-simple-split-string reply "\n+"))) - (mapc 'dictionary-display-strategy-line list)) + (mapc #'dictionary-display-strategy-line list)) (dictionary-post-buffer)) (defun dictionary-display-strategy-line (string) @@ -1030,7 +1030,7 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." 'help-echo (purecopy "Mouse-2 to select this matching algorithm")) (insert "\n"))))) -(defun dictionary-set-strategy (strategy &rest ignored) +(defun dictionary-set-strategy (strategy &rest _ignored) "Select this STRATEGY as new default." (setq dictionary-default-strategy strategy) (dictionary-restore-state) @@ -1194,7 +1194,7 @@ allows editing it." (describe-function 'dictionary-mode)) ;;;###autoload -(defun dictionary-match-words (&optional pattern &rest ignored) +(defun dictionary-match-words (&optional pattern &rest _ignored) "Search PATTERN in current default dictionary using default strategy." (interactive) ;; can't use interactive because of mouse events @@ -1270,7 +1270,7 @@ allows editing it." (defun dictionary-read-definition (&ignore) (let ((list (dictionary-simple-split-string (dictionary-read-answer) "\n+"))) - (mapconcat 'identity (cdr list) "\n"))) + (mapconcat #'identity (cdr list) "\n"))) ;;; Tooltip support for GNU Emacs (defvar global-dictionary-tooltip-mode @@ -1322,8 +1322,8 @@ will be set to nil." (interactive) (tooltip-mode on) (if on - (add-hook 'tooltip-functions 'dictionary-display-tooltip) - (remove-hook 'tooltip-functions 'dictionary-display-tooltip))) + (add-hook 'tooltip-functions #'dictionary-display-tooltip) + (remove-hook 'tooltip-functions #'dictionary-display-tooltip))) ;;;###autoload (defun dictionary-tooltip-mode (&optional arg) @@ -1364,9 +1364,8 @@ any buffer where (dictionary-tooltip-mode 1) has been called." (make-local-variable 'dictionary-tooltip-mouse-event) (setq-default track-mouse on) (dictionary-switch-tooltip-mode 1) - (if on - (global-set-key [mouse-movement] 'dictionary-tooltip-track-mouse) - (global-set-key [mouse-movement] 'ignore)) + (global-set-key [mouse-movement] + (if on #'dictionary-tooltip-track-mouse #'ignore)) on)) (provide 'dictionary) diff --git a/lisp/net/dig.el b/lisp/net/dig.el index 92dcf73250b..ddbfb9598b8 100644 --- a/lisp/net/dig.el +++ b/lisp/net/dig.el @@ -79,7 +79,7 @@ and is a commonly available debugging tool." (push domain cmdline) (if server (push (concat "@" server) cmdline) (if dig-dns-server (push (concat "@" dig-dns-server) cmdline))) - (apply 'call-process dig-program nil buf nil cmdline) + (apply #'call-process dig-program nil buf nil cmdline) buf)) (defun dig-extract-rr (domain &optional type class) @@ -120,7 +120,7 @@ Buffer should contain output generated by `dig-invoke'." (defvar dig-mode-map (let ((map (make-sparse-keymap))) (define-key map "g" nil) - (define-key map "q" 'dig-exit) + (define-key map "q" #'dig-exit) map)) (define-derived-mode dig-mode special-mode "Dig" diff --git a/lisp/net/dns.el b/lisp/net/dns.el index 90776e3c6f2..1086bab9466 100644 --- a/lisp/net/dns.el +++ b/lisp/net/dns.el @@ -135,8 +135,8 @@ updated. Set this variable to t to disable the check.") (if (stringp ended) (if (null name) ended - (concat (mapconcat 'identity (nreverse name) ".") "." ended)) - (mapconcat 'identity (nreverse name) ".")))) + (concat (mapconcat #'identity (nreverse name) ".") "." ended)) + (mapconcat #'identity (nreverse name) ".")))) (defun dns-write (spec &optional tcp-p) "Write a DNS packet according to SPEC. @@ -283,7 +283,7 @@ If TCP-P, the first two bytes of the packet will be the length field." (let ((bytes nil)) (dotimes (_ 4) (push (dns-read-bytes 1) bytes)) - (mapconcat 'number-to-string (nreverse bytes) "."))) + (mapconcat #'number-to-string (nreverse bytes) "."))) ((eq type 'AAAA) (let (hextets) (dotimes (_ 8) @@ -386,7 +386,7 @@ If REVERSE, look up an IP address." (when reverse (setq name (concat - (mapconcat 'identity (nreverse (split-string name "\\.")) ".") + (mapconcat #'identity (nreverse (split-string name "\\.")) ".") ".in-addr.arpa") type 'PTR)) diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el index 456d70ee0fe..1d7af7f5b5f 100644 --- a/lisp/net/eudc-bob.el +++ b/lisp/net/eudc-bob.el @@ -41,38 +41,38 @@ (defvar eudc-bob-generic-keymap (let ((map (make-sparse-keymap))) - (define-key map "s" 'eudc-bob-save-object) - (define-key map "!" 'eudc-bob-pipe-object-to-external-program) - (define-key map [down-mouse-3] 'eudc-bob-popup-menu) + (define-key map "s" #'eudc-bob-save-object) + (define-key map "!" #'eudc-bob-pipe-object-to-external-program) + (define-key map [down-mouse-3] #'eudc-bob-popup-menu) map) "Keymap for multimedia objects.") (defvar eudc-bob-image-keymap (let ((map (make-sparse-keymap))) (set-keymap-parent map eudc-bob-generic-keymap) - (define-key map "t" 'eudc-bob-toggle-inline-display) + (define-key map "t" #'eudc-bob-toggle-inline-display) map) "Keymap for inline images.") (defvar eudc-bob-sound-keymap (let ((map (make-sparse-keymap))) (set-keymap-parent map eudc-bob-generic-keymap) - (define-key map (kbd "RET") 'eudc-bob-play-sound-at-point) - (define-key map [down-mouse-2] 'eudc-bob-play-sound-at-mouse) + (define-key map (kbd "RET") #'eudc-bob-play-sound-at-point) + (define-key map [down-mouse-2] #'eudc-bob-play-sound-at-mouse) map) "Keymap for inline sounds.") (defvar eudc-bob-url-keymap (let ((map (make-sparse-keymap))) - (define-key map (kbd "RET") 'browse-url-at-point) - (define-key map [down-mouse-2] 'browse-url-at-mouse) + (define-key map (kbd "RET") #'browse-url-at-point) + (define-key map [down-mouse-2] #'browse-url-at-mouse) map) "Keymap for inline urls.") (defvar eudc-bob-mail-keymap (let ((map (make-sparse-keymap))) - (define-key map (kbd "RET") 'goto-address-at-point) - (define-key map [down-mouse-2] 'goto-address-at-point) + (define-key map (kbd "RET") #'goto-address-at-point) + (define-key map [down-mouse-2] #'goto-address-at-point) map) "Keymap for inline e-mail addresses.") diff --git a/lisp/net/eudc-export.el b/lisp/net/eudc-export.el index bac75e6555d..66db7814ad8 100644 --- a/lisp/net/eudc-export.el +++ b/lisp/net/eudc-export.el @@ -1,4 +1,4 @@ -;;; eudc-export.el --- functions to export EUDC query results +;;; eudc-export.el --- functions to export EUDC query results -*- lexical-binding: t; -*- ;; Copyright (C) 1998-2021 Free Software Foundation, Inc. @@ -35,6 +35,7 @@ ;; NOERROR is so we can compile it. (require 'bbdb nil t) (require 'bbdb-com nil t) +(require 'cl-lib) (defun eudc-create-bbdb-record (record &optional silent) "Create a BBDB record using the RECORD alist. @@ -42,24 +43,22 @@ RECORD is an alist of (KEY . VALUE) where KEY is a directory attribute name symbol and VALUE is the corresponding value for the record. If SILENT is non-nil then the created BBDB record is not displayed." (require 'bbdb) + (declare-function bbdb-create-internal "bbdb-com" (&rest spec)) + (declare-function bbdb-display-records "bbdb" + (records &optional layout append)) ;; This function runs in a special context where lisp symbols corresponding ;; to field names in record are bound to the corresponding values - (eval - `(let* (,@(mapcar (lambda (c) - (list (car c) (if (listp (cdr c)) - (list 'quote (cdr c)) - (cdr c)))) - record) - bbdb-name - bbdb-company - bbdb-net - bbdb-address - bbdb-phones - bbdb-notes - spec - bbdb-record - value - (conversion-alist (symbol-value eudc-bbdb-conversion-alist))) + (cl-progv (mapcar #'car record) (mapcar #'cdr record) + (let* (bbdb-name + bbdb-company + bbdb-net + bbdb-address + bbdb-phones + bbdb-notes + spec + bbdb-record + value + (conversion-alist (symbol-value eudc-bbdb-conversion-alist))) ;; BBDB standard fields (setq bbdb-name (eudc-parse-spec (cdr (assq 'name conversion-alist)) record nil) @@ -68,14 +67,14 @@ If SILENT is non-nil then the created BBDB record is not displayed." bbdb-notes (eudc-parse-spec (cdr (assq 'notes conversion-alist)) record nil)) (setq spec (cdr (assq 'address conversion-alist))) (setq bbdb-address (delq nil (eudc-parse-spec (if (listp (car spec)) - spec - (list spec)) - record t))) + spec + (list spec)) + record t))) (setq spec (cdr (assq 'phone conversion-alist))) (setq bbdb-phones (delq nil (eudc-parse-spec (if (listp (car spec)) - spec - (list spec)) - record t))) + spec + (list spec)) + record t))) ;; BBDB custom fields (setq bbdb-notes (append (list (and bbdb-notes (cons 'notes bbdb-notes))) (mapcar (lambda (mapping) @@ -85,19 +84,20 @@ If SILENT is non-nil then the created BBDB record is not displayed." (cons (car mapping) value))) conversion-alist))) (setq bbdb-notes (delq nil bbdb-notes)) - (setq bbdb-record (bbdb-create-internal - bbdb-name - ,@(when (eudc--using-bbdb-3-or-newer-p) - '(nil - nil)) - bbdb-company - bbdb-net - ,@(if (eudc--using-bbdb-3-or-newer-p) - '(bbdb-phones - bbdb-address) - '(bbdb-address - bbdb-phones)) - bbdb-notes)) + (setq bbdb-record + (apply #'bbdb-create-internal + `(,bbdb-name + ,@(when (eudc--using-bbdb-3-or-newer-p) + '(nil + nil)) + ,bbdb-company + ,bbdb-net + ,@(if (eudc--using-bbdb-3-or-newer-p) + (list bbdb-phones + bbdb-address) + (list bbdb-address + bbdb-phones)) + ,bbdb-notes))) (or silent (bbdb-display-records (list bbdb-record)))))) @@ -111,7 +111,7 @@ If RECURSE is non-nil then SPEC may be a list of atomic specs." (symbolp (car spec)) (fboundp (car spec)))) (condition-case nil - (eval spec) + (eval spec t) (void-variable nil))) ((and recurse (listp spec)) @@ -194,9 +194,9 @@ LOCATION is used as the phone location for BBDB." (signal (car err) (cdr err))))) (if (= 3 (length phone-list)) (setq phone-list (append phone-list '(nil)))) - (apply 'vector location phone-list))) + (apply #'vector location phone-list))) ((listp phone) - (vector location (mapconcat 'identity phone ", "))) + (vector location (mapconcat #'identity phone ", "))) (t (error "Invalid phone specification")))) diff --git a/lisp/net/eudc-hotlist.el b/lisp/net/eudc-hotlist.el index e4b7e8ae71b..a737a99ce95 100644 --- a/lisp/net/eudc-hotlist.el +++ b/lisp/net/eudc-hotlist.el @@ -1,4 +1,4 @@ -;;; eudc-hotlist.el --- hotlist management for EUDC +;;; eudc-hotlist.el --- hotlist management for EUDC -*- lexical-binding: t; -*- ;; Copyright (C) 1998-2021 Free Software Foundation, Inc. @@ -37,12 +37,12 @@ (defvar eudc-hotlist-mode-map (let ((map (make-sparse-keymap))) - (define-key map "a" 'eudc-hotlist-add-server) - (define-key map "d" 'eudc-hotlist-delete-server) - (define-key map "s" 'eudc-hotlist-select-server) - (define-key map "t" 'eudc-hotlist-transpose-servers) - (define-key map "q" 'eudc-hotlist-quit-edit) - (define-key map "x" 'kill-current-buffer) + (define-key map "a" #'eudc-hotlist-add-server) + (define-key map "d" #'eudc-hotlist-delete-server) + (define-key map "s" #'eudc-hotlist-select-server) + (define-key map "t" #'eudc-hotlist-transpose-servers) + (define-key map "q" #'eudc-hotlist-quit-edit) + (define-key map "x" #'kill-current-buffer) map)) (define-derived-mode eudc-hotlist-mode fundamental-mode "EUDC-Servers" diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 4f048045d52..c112d273309 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -65,12 +65,12 @@ (defvar eudc-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent map widget-keymap) - (define-key map "q" 'kill-current-buffer) - (define-key map "x" 'kill-current-buffer) - (define-key map "f" 'eudc-query-form) - (define-key map "b" 'eudc-try-bbdb-insert) - (define-key map "n" 'eudc-move-to-next-record) - (define-key map "p" 'eudc-move-to-previous-record) + (define-key map "q" #'kill-current-buffer) + (define-key map "x" #'kill-current-buffer) + (define-key map "f" #'eudc-query-form) + (define-key map "b" #'eudc-try-bbdb-insert) + (define-key map "n" #'eudc-move-to-next-record) + (define-key map "p" #'eudc-move-to-previous-record) map)) (defvar mode-popup-menu) @@ -407,7 +407,7 @@ if any, is called to print the value in cdr of FIELD." (val (cdr field))) (if match (progn - (eval (list (cdr match) val)) + (funcall (cdr match) val) (insert "\n")) (mapc (lambda (val-elem) diff --git a/lisp/net/eudcb-bbdb.el b/lisp/net/eudcb-bbdb.el index e11458b29cb..e241a1c2fac 100644 --- a/lisp/net/eudcb-bbdb.el +++ b/lisp/net/eudcb-bbdb.el @@ -1,4 +1,4 @@ -;;; eudcb-bbdb.el --- Emacs Unified Directory Client - BBDB Backend +;;; eudcb-bbdb.el --- Emacs Unified Directory Client - BBDB Backend -*- lexical-binding: t; -*- ;; Copyright (C) 1998-2021 Free Software Foundation, Inc. @@ -34,6 +34,7 @@ ;; Make it loadable on systems without bbdb. (require 'bbdb nil t) (require 'bbdb-com nil t) +(require 'seq) ;;{{{ Internal cooking @@ -87,33 +88,30 @@ BBDB < 3 used `net'; BBDB >= 3 uses `mail'." "Return RECORD if it matches `eudc-bbdb-current-query', nil otherwise." (require 'bbdb) (catch 'unmatch - (progn - (dolist (condition eudc-bbdb-current-query) - (let ((attr (car condition)) - (val (cdr condition)) - (case-fold-search t) - bbdb-val) - (or (and (memq attr '(firstname lastname aka company phones - addresses net)) - (progn - (setq bbdb-val - (eval (list (intern (concat "bbdb-record-" - (symbol-name - (eudc-bbdb-field - attr)))) - 'record))) - (if (listp bbdb-val) - (if eudc-bbdb-enable-substring-matches - (eval `(or ,@(mapcar (lambda (subval) - (string-match val subval)) - bbdb-val))) - (member (downcase val) - (mapcar 'downcase bbdb-val))) + (dolist (condition eudc-bbdb-current-query) + (let ((attr (car condition)) + (val (cdr condition)) + (case-fold-search t)) + (or (and (memq attr '(firstname lastname aka company phones + addresses net)) + (let ((bbdb-val + (funcall (intern (concat "bbdb-record-" + (symbol-name + (eudc-bbdb-field + attr)))) + record))) + (if (listp bbdb-val) (if eudc-bbdb-enable-substring-matches - (string-match val bbdb-val) - (string-equal (downcase val) (downcase bbdb-val)))))) - (throw 'unmatch nil)))) - record))) + (seq-some (lambda (subval) + (string-match val subval)) + bbdb-val) + (member (downcase val) + (mapcar #'downcase bbdb-val))) + (if eudc-bbdb-enable-substring-matches + (string-match val bbdb-val) + (string-equal (downcase val) (downcase bbdb-val)))))) + (throw 'unmatch nil)))) + record)) ;; External. (declare-function bbdb-phone-location "ext:bbdb" t) ; via bbdb-defstruct @@ -182,40 +180,34 @@ The record is filtered according to `eudc-bbdb-current-return-attributes'." (require 'bbdb) (let ((attrs (or eudc-bbdb-current-return-attributes '(firstname lastname aka company phones addresses net notes))) - attr - eudc-rec - val) - (while (prog1 - (setq attr (car attrs)) - (setq attrs (cdr attrs))) - (cond - ((eq attr 'phones) - (setq val (eudc-bbdb-extract-phones record))) - ((eq attr 'addresses) - (setq val (eudc-bbdb-extract-addresses record))) - ((eq attr 'notes) - (if (eudc--using-bbdb-3-or-newer-p) - (setq val (bbdb-record-xfield record 'notes)) - (setq val (bbdb-record-notes record)))) - ((memq attr '(firstname lastname aka company net)) - (setq val (eval - (list (intern - (concat "bbdb-record-" - (symbol-name (eudc-bbdb-field attr)))) - 'record)))) - (t - (error "Unknown BBDB attribute"))) - (cond - ((or (not val) (equal val ""))) ; do nothing - ((memq attr '(phones addresses)) - (setq eudc-rec (append val eudc-rec))) - ((and (listp val) - (= 1 (length val))) - (setq eudc-rec (cons (cons attr (car val)) eudc-rec))) - ((> (length val) 0) - (setq eudc-rec (cons (cons attr val) eudc-rec))) - (t - (error "Unexpected attribute value")))) + eudc-rec) + (dolist (attr attrs) + (let ((val + (pcase attr + ('phones (eudc-bbdb-extract-phones record)) + ('addresses (eudc-bbdb-extract-addresses record)) + ('notes + (if (eudc--using-bbdb-3-or-newer-p) + (bbdb-record-xfield record 'notes) + (bbdb-record-notes record))) + ((or 'firstname 'lastname 'aka 'company 'net) + (funcall (intern + (concat "bbdb-record-" + (symbol-name (eudc-bbdb-field attr)))) + record)) + (_ + (error "Unknown BBDB attribute"))))) + (cond + ((or (not val) (equal val ""))) ; do nothing + ((memq attr '(phones addresses)) + (setq eudc-rec (append val eudc-rec))) + ((and (listp val) + (= 1 (length val))) + (push (cons attr (car val)) eudc-rec)) + ((> (length val) 0) + (push (cons attr val) eudc-rec)) + (t + (error "Unexpected attribute value"))))) (nreverse eudc-rec))) @@ -240,21 +232,20 @@ RETURN-ATTRS is a list of attributes to return, defaulting to (while (and records (> (length query-attrs) 0)) (setq bbdb-attrs (append bbdb-attrs (list (car query-attrs)))) (if (car query-attrs) - (setq records (eval `(bbdb-search ,(quote records) ,@bbdb-attrs)))) + ;; BEWARE: `bbdb-search' is a macro! + (setq records (eval `(bbdb-search records ,@bbdb-attrs) t))) (setq query-attrs (cdr query-attrs))) (mapc (lambda (record) (setq filtered (eudc-filter-duplicate-attributes record)) ;; If there were duplicate attributes reverse the order of the ;; record so the unique attributes appear first (if (> (length filtered) 1) - (setq filtered (mapcar (lambda (rec) - (reverse rec)) - filtered))) + (setq filtered (mapcar #'reverse filtered))) (setq result (append result filtered))) (delq nil - (mapcar 'eudc-bbdb-format-record-as-result + (mapcar #'eudc-bbdb-format-record-as-result (delq nil - (mapcar 'eudc-bbdb-filter-non-matching-record + (mapcar #'eudc-bbdb-filter-non-matching-record records))))) result)) diff --git a/lisp/net/eudcb-ldap.el b/lisp/net/eudcb-ldap.el index 4623079ea9f..0aff276475e 100644 --- a/lisp/net/eudcb-ldap.el +++ b/lisp/net/eudcb-ldap.el @@ -1,4 +1,4 @@ -;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend +;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend -*- lexical-binding: t; -*- ;; Copyright (C) 1998-2021 Free Software Foundation, Inc. @@ -38,10 +38,10 @@ ;;{{{ Internal cooking -(eval-and-compile +(defalias 'eudc-ldap-get-host-parameter (if (fboundp 'ldap-get-host-parameter) - (fset 'eudc-ldap-get-host-parameter 'ldap-get-host-parameter) - (defun eudc-ldap-get-host-parameter (host parameter) + #'ldap-get-host-parameter + (lambda (host parameter) "Get the value of PARAMETER for HOST in `ldap-host-parameters-alist'." (plist-get (cdr (assoc host ldap-host-parameters-alist)) parameter)))) @@ -84,7 +84,7 @@ record)) (defun eudc-filter-$ (string) - (mapconcat 'identity (split-string string "\\$") "\n")) + (mapconcat #'identity (split-string string "\\$") "\n")) (defun eudc-ldap-cleanup-record-filtering-addresses (record) "Clean up RECORD to make it suitable for EUDC. @@ -104,7 +104,7 @@ multiple addresses." (value (cdr field))) (when (and clean-up-addresses (memq name '(postaladdress registeredaddress))) - (setq value (mapcar 'eudc-filter-$ value))) + (setq value (mapcar #'eudc-filter-$ value))) (if (eq name 'mail) (setq mail-addresses (append mail-addresses value)) (push (cons name (if (cdr value) @@ -126,9 +126,9 @@ RETURN-ATTRS is a list of attributes to return, defaulting to (let ((result (ldap-search (eudc-ldap-format-query-as-rfc1558 query) eudc-server (if (listp return-attrs) - (mapcar 'symbol-name return-attrs)))) + (mapcar #'symbol-name return-attrs)))) final-result) - (setq result (mapcar 'eudc-ldap-cleanup-record-filtering-addresses result)) + (setq result (mapcar #'eudc-ldap-cleanup-record-filtering-addresses result)) (if (and eudc-strict-return-matches return-attrs @@ -154,7 +154,7 @@ attribute names are returned. Default to `person'." (let ((ldap-host-parameters-alist (list (cons eudc-server '(scope subtree sizelimit 1))))) - (mapcar 'eudc-ldap-cleanup-record-filtering-addresses + (mapcar #'eudc-ldap-cleanup-record-filtering-addresses (ldap-search (eudc-ldap-format-query-as-rfc1558 (list (cons "objectclass" diff --git a/lisp/net/eudcb-mab.el b/lisp/net/eudcb-mab.el index eb7032ac4c8..732881f75a0 100644 --- a/lisp/net/eudcb-mab.el +++ b/lisp/net/eudcb-mab.el @@ -1,4 +1,4 @@ -;;; eudcb-mab.el --- Emacs Unified Directory Client - AddressBook backend +;;; eudcb-mab.el --- Emacs Unified Directory Client - AddressBook backend -*- lexical-binding: t; -*- ;; Copyright (C) 2003-2021 Free Software Foundation, Inc. diff --git a/lisp/net/eudcb-macos-contacts.el b/lisp/net/eudcb-macos-contacts.el index b07016c1229..18c8958c160 100644 --- a/lisp/net/eudcb-macos-contacts.el +++ b/lisp/net/eudcb-macos-contacts.el @@ -1,4 +1,4 @@ -;;; eudcb-macos-contacts.el --- EUDC - macOS Contacts backend +;;; eudcb-macos-contacts.el --- EUDC - macOS Contacts backend -*- lexical-binding: t; -*- ;; Copyright (C) 2020-2021 Free Software Foundation, Inc. @@ -74,7 +74,7 @@ end tell" str)) "`osascript' executable not found. " "Is this is a macOS 10.0 or later system?")))) -(defun eudc-macos-contacts-query-internal (query &optional return-attrs) +(defun eudc-macos-contacts-query-internal (query &optional _return-attrs) "Query macOS Contacts with QUERY. QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid macOS Contacts attribute names. diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index ff58cbb035e..9c7bcdc261a 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -1,4 +1,4 @@ -;;; gnutls.el --- Support SSL/TLS connections through GnuTLS +;;; gnutls.el --- Support SSL/TLS connections through GnuTLS -*- lexical-binding: t; -*- ;; Copyright (C) 2010-2021 Free Software Foundation, Inc. @@ -59,7 +59,6 @@ general, Emacs network security is handled by the Network Security Manager (NSM), and the default value of nil delegates the job of checking the connection security to the NSM. See Info node `(emacs) Network Security'." - :group 'gnutls :type '(choice (const nil) string)) @@ -91,7 +90,6 @@ checks are performed at the gnutls level. Instead the checks are performed via `open-network-stream' at a higher level by the Network Security Manager. See Info node `(emacs) Network Security'." - :group 'gnutls :version "24.4" :type '(choice (const t) @@ -118,7 +116,6 @@ Security'." If a file path contains glob wildcards, they will be expanded. The files may be in PEM or DER format, as per the GnuTLS documentation. The files may not exist, in which case they will be ignored." - :group 'gnutls :type '(choice (function :tag "Function to produce list of bundle filenames") (repeat (file :tag "Bundle filename")))) @@ -139,7 +136,6 @@ network security is handled at a higher level via node `(emacs) Network Security'." :type '(choice (const :tag "Use default value" nil) (integer :tag "Number of bits" 2048)) - :group 'gnutls :version "27.1") (defcustom gnutls-crlfiles @@ -150,7 +146,6 @@ node `(emacs) Network Security'." If a file path contains glob wildcards, they will be expanded. The files may be in PEM or DER format, as per the GnuTLS documentation. The files may not exist, in which case they will be ignored." - :group 'gnutls :type '(choice (function :tag "Function to produce list of CRL filenames") (repeat (file :tag "CRL filename"))) :version "27.1") diff --git a/lisp/net/goto-addr.el b/lisp/net/goto-addr.el index d1926302470..af12f6970a6 100644 --- a/lisp/net/goto-addr.el +++ b/lisp/net/goto-addr.el @@ -1,4 +1,4 @@ -;;; goto-addr.el --- click to browse URL or to send to e-mail address +;;; goto-addr.el --- click to browse URL or to send to e-mail address -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 2000-2021 Free Software Foundation, Inc. @@ -73,19 +73,16 @@ (defcustom goto-address-fontify-p t "Non-nil means URLs and e-mail addresses in buffer are fontified. But only if `goto-address-highlight-p' is also non-nil." - :type 'boolean - :group 'goto-address) + :type 'boolean) (defcustom goto-address-highlight-p t "Non-nil means URLs and e-mail addresses in buffer are highlighted." - :type 'boolean - :group 'goto-address) + :type 'boolean) (defcustom goto-address-fontify-maximum-size 30000 "Maximum size of file in which to fontify and/or highlight URLs. A value of t means there is no limit--fontify regardless of the size." - :type '(choice (integer :tag "Maximum size") (const :tag "No limit" t)) - :group 'goto-address) + :type '(choice (integer :tag "Maximum size") (const :tag "No limit" t))) (defvar goto-address-mail-regexp ;; Actually pretty much any char could appear in the username part. -stef @@ -122,30 +119,26 @@ will have no effect.") (defvar goto-address-highlight-keymap (let ((m (make-sparse-keymap))) - (define-key m (kbd "") 'goto-address-at-point) - (define-key m (kbd "C-c RET") 'goto-address-at-point) + (define-key m (kbd "") #'goto-address-at-point) + (define-key m (kbd "C-c RET") #'goto-address-at-point) m) "Keymap to hold goto-addr's mouse key defs under highlighted URLs.") (defcustom goto-address-url-face 'link "Face to use for URLs." - :type 'face - :group 'goto-address) + :type 'face) (defcustom goto-address-url-mouse-face 'highlight "Face to use for URLs when the mouse is on them." - :type 'face - :group 'goto-address) + :type 'face) (defcustom goto-address-mail-face 'italic "Face to use for e-mail addresses." - :type 'face - :group 'goto-address) + :type 'face) (defcustom goto-address-mail-mouse-face 'secondary-selection "Face to use for e-mail addresses when the mouse is on them." - :type 'face - :group 'goto-address) + :type 'face) (defun goto-address-unfontify (start end) "Remove `goto-address' fontification from the given region." @@ -287,7 +280,6 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and ;;;###autoload (define-globalized-minor-mode global-goto-address-mode goto-address-mode goto-addr-mode--turn-on - :group 'goto-address :version "28.1") ;;;###autoload diff --git a/lisp/net/net-utils.el b/lisp/net/net-utils.el index d5aad3a3f77..3a561a0ea51 100644 --- a/lisp/net/net-utils.el +++ b/lisp/net/net-utils.el @@ -1,4 +1,4 @@ -;;; net-utils.el --- network functions +;;; net-utils.el --- network functions -*- lexical-binding: t; -*- ;; Copyright (C) 1998-2021 Free Software Foundation, Inc. @@ -67,17 +67,14 @@ "tracert" "traceroute") "Program to trace network hops to a destination." - :group 'net-utils :type 'string) (defcustom traceroute-program-options nil "Options for the traceroute program." - :group 'net-utils :type '(repeat string)) (defcustom ping-program "ping" "Program to send network test packets to a host." - :group 'net-utils :type 'string) ;; On GNU/Linux and Irix, the system's ping program seems to send packets @@ -87,7 +84,6 @@ (list "-c" "4")) "Options for the ping program. These options can be used to limit how many ICMP packets are emitted." - :group 'net-utils :type '(repeat string)) (defcustom ifconfig-program @@ -98,7 +94,6 @@ These options can be used to limit how many ICMP packets are emitted." (t "ip")) "Program to print network configuration information." :version "25.1" ; add ip - :group 'net-utils :type 'string) (defcustom ifconfig-program-options @@ -108,7 +103,6 @@ These options can be used to limit how many ICMP packets are emitted." "Options for the ifconfig program." :version "25.1" :set-after '(ifconfig-program) - :group 'net-utils :type '(repeat string)) (defcustom iwconfig-program @@ -116,7 +110,6 @@ These options can be used to limit how many ICMP packets are emitted." ((net-utils--executable-find-sbin "iw") "iw") (t "iw")) "Program to print wireless network configuration information." - :group 'net-utils :type 'string :version "26.1") @@ -124,7 +117,6 @@ These options can be used to limit how many ICMP packets are emitted." (cond ((string-match-p "iw\\'" iwconfig-program) (list "dev")) (t nil)) "Options for the iwconfig program." - :group 'net-utils :type '(repeat string) :version "26.1") @@ -133,25 +125,21 @@ These options can be used to limit how many ICMP packets are emitted." ((net-utils--executable-find-sbin "ss")) (t "ss")) "Program to print network statistics." - :group 'net-utils :type 'string :version "26.1") (defcustom netstat-program-options (list "-a") "Options for the netstat program." - :group 'net-utils :type '(repeat string)) (defcustom arp-program (or (net-utils--executable-find-sbin "arp") "arp") "Program to print IP to address translation tables." - :group 'net-utils :type 'string) (defcustom arp-program-options (list "-a") "Options for the arp program." - :group 'net-utils :type '(repeat string)) (defcustom route-program @@ -162,7 +150,6 @@ These options can be used to limit how many ICMP packets are emitted." ((net-utils--executable-find-sbin "ip")) (t "ip")) "Program to print routing tables." - :group 'net-utils :type 'string :version "26.1") @@ -171,18 +158,15 @@ These options can be used to limit how many ICMP packets are emitted." ((string-match-p "netstat\\'" route-program) (list "-r")) (t (list "route"))) "Options for the route program." - :group 'net-utils :type '(repeat string) :version "26.1") (defcustom nslookup-program "nslookup" "Program to interactively query DNS information." - :group 'net-utils :type 'string) (defcustom nslookup-program-options nil "Options for the nslookup program." - :group 'net-utils :type '(repeat string)) (defcustom nslookup-prompt-regexp "^> " @@ -190,28 +174,23 @@ These options can be used to limit how many ICMP packets are emitted." This variable is only used if the variable `comint-use-prompt-regexp' is non-nil." - :group 'net-utils :type 'regexp) (defcustom dig-program "dig" "Program to query DNS information." - :group 'net-utils :type 'string) (defcustom dig-program-options nil "Options for the dig program." - :group 'net-utils :type '(repeat string) :version "26.1") (defcustom ftp-program "ftp" "Program to run to do FTP transfers." - :group 'net-utils :type 'string) (defcustom ftp-program-options nil "Options for the ftp program." - :group 'net-utils :type '(repeat string)) (defcustom ftp-prompt-regexp "^ftp>" @@ -219,17 +198,14 @@ This variable is only used if the variable This variable is only used if the variable `comint-use-prompt-regexp' is non-nil." - :group 'net-utils :type 'regexp) (defcustom smbclient-program "smbclient" "Smbclient program." - :group 'net-utils :type 'string) (defcustom smbclient-program-options nil "Options for the smbclient program." - :group 'net-utils :type '(repeat string)) (defcustom smbclient-prompt-regexp "^smb: >" @@ -237,17 +213,14 @@ This variable is only used if the variable This variable is only used if the variable `comint-use-prompt-regexp' is non-nil." - :group 'net-utils :type 'regexp) (defcustom dns-lookup-program "host" "Program to interactively query DNS information." - :group 'net-utils :type 'string) (defcustom dns-lookup-program-options nil "Options for the dns-lookup program." - :group 'net-utils :type '(repeat string)) ;; Internal variables @@ -265,7 +238,7 @@ This variable is only used if the variable 1 'font-lock-keyword-face) ;; Dotted quads (list - (mapconcat 'identity + (mapconcat #'identity (make-list 4 "[0-9]+") "\\.") 0 'font-lock-variable-name-face) @@ -273,7 +246,7 @@ This variable is only used if the variable (list (let ((host-expression "[-A-Za-z0-9]+")) (concat - (mapconcat 'identity + (mapconcat #'identity (make-list 2 host-expression) "\\.") "\\(\\." host-expression "\\)*")) @@ -288,7 +261,7 @@ This variable is only used if the variable (list ;; Dotted quads (list - (mapconcat 'identity (make-list 4 "[0-9]+") "\\.") + (mapconcat #'identity (make-list 4 "[0-9]+") "\\.") 0 'font-lock-variable-name-face) ;; Simple rfc4291 addresses (list (concat @@ -300,7 +273,7 @@ This variable is only used if the variable (list (let ((host-expression "[-A-Za-z0-9]+")) (concat - (mapconcat 'identity (make-list 2 host-expression) "\\.") + (mapconcat #'identity (make-list 2 host-expression) "\\.") "\\(\\." host-expression "\\)*")) 0 'font-lock-variable-name-face)) "Expressions to font-lock for general network utilities.") @@ -371,8 +344,8 @@ This variable is only used if the variable (erase-buffer) (insert header "\n") (set-process-filter - (apply 'start-process name buf program args) - 'net-utils-remove-ctrl-m-filter) + (apply #'start-process name buf program args) + #'net-utils-remove-ctrl-m-filter) (display-buffer buf) buf)) @@ -405,12 +378,12 @@ This variable is only used if the variable `(net-utils-run-simple ,(current-buffer) ,program-name ,args nodisplay)) (set-process-filter - (apply 'start-process program-name - (current-buffer) program-name args) - 'net-utils-remove-ctrl-m-filter) + (apply #'start-process program-name + (current-buffer) program-name args) + #'net-utils-remove-ctrl-m-filter) (unless nodisplay (display-buffer (current-buffer))))) -(defun net-utils--revert-function (&optional ignore-auto noconfirm) +(defun net-utils--revert-function (&optional _ignore-auto _noconfirm) (message "Reverting `%s'..." (buffer-name)) (apply (car net-utils--revert-cmd) (cdr net-utils--revert-cmd)) (let ((proc (get-buffer-process (current-buffer)))) @@ -430,7 +403,7 @@ This variable is only used if the variable ifconfig-program ifconfig-program-options)) -(defalias 'ipconfig 'ifconfig) +(defalias 'ipconfig #'ifconfig) ;;;###autoload (defun iwconfig () @@ -532,7 +505,7 @@ in Lisp code." (net-utils-run-program "Nslookup" (concat "** " - (mapconcat 'identity + (mapconcat #'identity (list "Nslookup" host nslookup-program) " ** ")) nslookup-program @@ -618,7 +591,7 @@ This command uses `nslookup-program' to look up DNS records." (defvar nslookup-mode-map (let ((map (make-sparse-keymap))) - (define-key map "\t" 'completion-at-point) + (define-key map "\t" #'completion-at-point) map)) ;; Using a derived mode gives us keymaps, hooks, etc. @@ -646,9 +619,9 @@ This command uses `dns-lookup-program' for looking up the DNS information." (net-utils-run-program (concat "DNS Lookup [" host "]") (concat "** " - (mapconcat 'identity - (list "DNS Lookup" host dns-lookup-program) - " ** ")) + (mapconcat #'identity + (list "DNS Lookup" host dns-lookup-program) + " ** ")) dns-lookup-program options))) @@ -669,13 +642,14 @@ This command uses `dig-program' for looking up the DNS information." (net-utils-run-program "Dig" (concat "** " - (mapconcat 'identity + (mapconcat #'identity (list "Dig" host dig-program) " ** ")) dig-program options))) (autoload 'comint-exec "comint") +(declare-function comint-watch-for-password-prompt "comint" (string)) ;; This is a lot less than ange-ftp, but much simpler. ;;;###autoload @@ -697,7 +671,7 @@ This command uses `dig-program' for looking up the DNS information." (defvar ftp-mode-map (let ((map (make-sparse-keymap))) ;; Occasionally useful - (define-key map "\t" 'completion-at-point) + (define-key map "\t" #'completion-at-point) map)) (define-derived-mode ftp-mode comint-mode "FTP" @@ -710,9 +684,9 @@ This command uses `dig-program' for looking up the DNS information." ;; password prompts will probably immediately follow the initial ;; connection), but it's better than getting prompted twice for the ;; same password. - (unless (memq 'comint-watch-for-password-prompt + (unless (memq #'comint-watch-for-password-prompt (default-value 'comint-output-filter-functions)) - (add-hook 'comint-output-filter-functions 'comint-watch-for-password-prompt + (add-hook 'comint-output-filter-functions #'comint-watch-for-password-prompt nil t))) (defun smbclient (host service) @@ -759,9 +733,9 @@ This command uses `smbclient-program' to connect to HOST." ;; password prompts will probably immediately follow the initial ;; connection), but it's better than getting prompted twice for the ;; same password. - (unless (memq 'comint-watch-for-password-prompt + (unless (memq #'comint-watch-for-password-prompt (default-value 'comint-output-filter-functions)) - (add-hook 'comint-output-filter-functions 'comint-watch-for-password-prompt + (add-hook 'comint-output-filter-functions #'comint-watch-for-password-prompt nil t))) @@ -810,7 +784,7 @@ This list is not complete.") (error "Could not open connection to %s" host)) (erase-buffer) (set-marker (process-mark tcp-connection) (point-min)) - (set-process-filter tcp-connection 'net-utils-remove-ctrl-m-filter) + (set-process-filter tcp-connection #'net-utils-remove-ctrl-m-filter) (and initial-string (process-send-string tcp-connection (concat initial-string "\r\n"))) @@ -825,7 +799,6 @@ This list is not complete.") If a host name passed to `finger' matches one of these regular expressions, it is assumed to be a host that doesn't accept queries of the form USER@HOST, and wants a query containing USER only." - :group 'net-utils :type '(repeat regexp) :version "21.1") @@ -852,7 +825,7 @@ and `network-connection-service-alist', which see." (let* ((user-and-host (concat user "@" host)) (process-name (concat "Finger [" user-and-host "]")) (regexps finger-X.500-host-regexps) - found) + ) ;; found (and regexps (while (not (string-match (car regexps) host)) (setq regexps (cdr regexps))) @@ -866,7 +839,6 @@ and `network-connection-service-alist', which see." (defcustom whois-server-name "rs.internic.net" "Default host name for the whois service." - :group 'net-utils :type 'string) (defcustom whois-server-list @@ -880,7 +852,6 @@ and `network-connection-service-alist', which see." ("whois.nic.gov") ("whois.ripe.net")) "A list of whois servers that can be queried." - :group 'net-utils :type '(repeat (list string))) ;; FIXME: modern whois clients include a much better tld <-> whois server @@ -903,14 +874,12 @@ and `network-connection-service-alist', which see." ("whois.nic.gov" . "gov") ("whois.nic.mil" . "mil")) "Alist to map top level domains to whois servers." - :group 'net-utils :type '(repeat (cons string string))) (defcustom whois-guess-server t "If non-nil then whois will try to deduce the appropriate whois server from the query. If the query doesn't look like a domain or hostname then the server named by `whois-server-name' is used." - :group 'net-utils :type 'boolean) (defun whois-get-tld (host) @@ -951,7 +920,6 @@ The port is deduced from `network-connection-service-alist'." (defcustom whois-reverse-lookup-server "whois.arin.net" "Server which provides inverse DNS mapping." - :group 'net-utils :type 'string) ;;;###autoload diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index b45cefcb442..1983688cef2 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -248,8 +248,7 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (list key cert))))))) ;;;###autoload -(defalias 'open-protocol-stream 'open-network-stream) -(define-obsolete-function-alias 'open-protocol-stream 'open-network-stream +(define-obsolete-function-alias 'open-protocol-stream #'open-network-stream "26.1") (defun network-stream-open-plain (name buffer host service parameters) diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index 418c1e2e966..c5488650b99 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -163,7 +163,7 @@ These were mostly extracted from the Radio Community Server You may add other entries in `newsticker-url-list'." :type `(set ,@(mapcar #'newsticker--splicer newsticker--raw-url-list-defaults)) - :set 'newsticker--set-customvar-retrieval + :set #'newsticker--set-customvar-retrieval :group 'newsticker-retrieval) (defcustom newsticker-url-list nil @@ -217,7 +217,7 @@ which apply for this feed only, overriding the value of (choice :tag "Wget Arguments" (const :tag "Default arguments" nil) (repeat :tag "Special arguments" string)))) - :set 'newsticker--set-customvar-retrieval + :set #'newsticker--set-customvar-retrieval :group 'newsticker-retrieval) (defcustom newsticker-retrieval-method @@ -260,7 +260,7 @@ make it less than 1800 seconds (30 minutes)!" (const :tag "Daily" 86400) (const :tag "Weekly" 604800) (integer :tag "Interval")) - :set 'newsticker--set-customvar-retrieval + :set #'newsticker--set-customvar-retrieval :group 'newsticker-retrieval) (defcustom newsticker-desc-comp-max @@ -549,7 +549,7 @@ name/timer pair to `newsticker--retrieval-timer-list'." (if (<= interval 0) (setq interval nil)) (setq timer (run-at-time start-time interval - 'newsticker-get-news feed-name)) + #'newsticker-get-news feed-name)) (if interval (add-to-list 'newsticker--retrieval-timer-list (cons feed-name timer)))))) @@ -727,10 +727,10 @@ See `newsticker-get-news'." (error "Another wget-process is running for %s" feed-name)) ;; start wget (let* ((args (append wget-arguments (list url))) - (proc (apply 'start-process feed-name buffername + (proc (apply #'start-process feed-name buffername newsticker-wget-name args))) (set-process-coding-system proc 'no-conversion 'no-conversion) - (set-process-sentinel proc 'newsticker--sentinel) + (set-process-sentinel proc #'newsticker--sentinel) (process-put proc 'nt-feed-name feed-name) (setq newsticker--process-ids (cons (process-id proc) newsticker--process-ids)) @@ -1131,9 +1131,9 @@ Restore an xml-string from a an xml NODE that was returned by xml-parse..." (children (cddr node))) (concat "<" qname (when att-list " ") - (mapconcat 'newsticker--unxml-attribute att-list " ") + (mapconcat #'newsticker--unxml-attribute att-list " ") ">" - (mapconcat 'newsticker--unxml children "") ""))) + (mapconcat #'newsticker--unxml children "") ""))) (defun newsticker--unxml-attribute (attribute) "Actually restore xml-string of an ATTRIBUTE of an xml node." @@ -1580,7 +1580,7 @@ Remove the pre-formatted from `newsticker--cache'." "Forget all cached pre-formatted data. Remove the pre-formatted from `newsticker--cache'." (mapc (lambda (feed) - (mapc 'newsticker--do-forget-preformatted + (mapc #'newsticker--do-forget-preformatted (cdr feed))) newsticker--cache) (when (fboundp 'newsticker--buffer-set-uptodate) @@ -1593,7 +1593,7 @@ This function calls `message' with arguments STRING and ARGS, if (and newsticker-debug ;;(not (active-minibuffer-window)) ;;(not (current-message)) - (apply 'message string args))) + (apply #'message string args))) (defun newsticker--decode-iso8601-date (string) "Return ISO8601-encoded STRING in format like `encode-time'. @@ -1751,10 +1751,10 @@ Save image as FILENAME in DIRECTORY, download it from URL." feed-name)) ;; start wget (let* ((args (append wget-arguments (list url))) - (proc (apply 'start-process proc-name buffername + (proc (apply #'start-process proc-name buffername newsticker-wget-name args))) (set-process-coding-system proc 'no-conversion 'no-conversion) - (set-process-sentinel proc 'newsticker--image-sentinel) + (set-process-sentinel proc #'newsticker--image-sentinel) (process-put proc 'nt-directory directory) (process-put proc 'nt-feed-name feed-name) (process-put proc 'nt-filename filename))))) @@ -2149,7 +2149,7 @@ FEED is a symbol!" "Save cache data for all feeds." (unless (file-directory-p newsticker-dir) (make-directory newsticker-dir t)) - (mapc 'newsticker--cache-save-feed newsticker--cache) + (mapc #'newsticker--cache-save-feed newsticker--cache) nil) (defun newsticker--cache-save-feed (feed) @@ -2223,7 +2223,7 @@ If AGES is nil, the total number of items is returned." (defun newsticker--stat-num-items-total (&optional age) "Return total number of items in all feeds which have the given AGE. If AGE is nil, the total number of items is returned." - (apply '+ + (apply #'+ (mapcar (lambda (feed) (if age (newsticker--stat-num-items (intern (car feed)) age) @@ -2395,7 +2395,7 @@ the item." (make-directory temp-dir t)) (cd temp-dir) (message "Getting image %s" url) - (apply 'start-process "wget-image" + (apply #'start-process "wget-image" " *newsticker-wget-download-images*" newsticker-wget-name (list url)) @@ -2417,7 +2417,7 @@ This function is suited for adding it to `newsticker-new-item-functions'." (make-directory temp-dir t)) (cd temp-dir) (message "Getting enclosure %s" url) - (apply 'start-process "wget-enclosure" + (apply #'start-process "wget-enclosure" " *newsticker-wget-download-enclosures*" newsticker-wget-name (list url)) diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el index 21d47b838f5..705bff666af 100644 --- a/lisp/net/newst-plainview.el +++ b/lisp/net/newst-plainview.el @@ -1,4 +1,4 @@ -;;; newst-plainview.el --- Single buffer frontend for newsticker. +;;; newst-plainview.el --- Single buffer frontend for newsticker. -*- lexical-binding: t; -*- ;; Copyright (C) 2003-2021 Free Software Foundation, Inc. @@ -90,7 +90,7 @@ The following sort methods are available: (const :tag "Keep original order" sort-by-original-order) (const :tag "Sort by time" sort-by-time) (const :tag "Sort by title" sort-by-title)) - :set 'newsticker--set-customvar-sorting + :set #'newsticker--set-customvar-sorting :group 'newsticker-plainview) (defcustom newsticker-heading-format @@ -107,7 +107,7 @@ The following printf-like specifiers can be used: %s The statistical data of the feed. See `newsticker-statistics-format'. %t The title of the feed, i.e. its name." :type 'string - :set 'newsticker--set-customvar-formatting + :set #'newsticker--set-customvar-formatting :group 'newsticker-plainview) (defcustom newsticker-item-format @@ -122,7 +122,7 @@ The following printf-like specifiers can be used: the title of the feed is used. %t The title of the item." :type 'string - :set 'newsticker--set-customvar-formatting + :set #'newsticker--set-customvar-formatting :group 'newsticker-plainview) (defcustom newsticker-desc-format @@ -133,7 +133,7 @@ The following printf-like specifiers can be used: %d The date the item was (first) retrieved. See `newsticker-date-format'." :type 'string - :set 'newsticker--set-customvar-formatting + :set #'newsticker--set-customvar-formatting :group 'newsticker-plainview) (defcustom newsticker-statistics-format @@ -146,7 +146,7 @@ The following printf-like specifiers can be used: %o The number of old items in the feed. %O The number of obsolete items in the feed." :type 'string - :set 'newsticker--set-customvar-formatting + :set #'newsticker--set-customvar-formatting :group 'newsticker-plainview) @@ -195,7 +195,7 @@ If set to t old items will be completely folded and only new items will show up in the *newsticker* buffer. Otherwise old as well as new items will be visible." :type 'boolean - :set 'newsticker--set-customvar-buffer + :set #'newsticker--set-customvar-buffer :group 'newsticker-plainview) (defcustom newsticker-show-descriptions-of-new-items @@ -204,14 +204,14 @@ well as new items will be visible." If set to t old items will be folded and new items will be unfolded. Otherwise old as well as new items will be folded." :type 'boolean - :set 'newsticker--set-customvar-buffer + :set #'newsticker--set-customvar-buffer :group 'newsticker-plainview) (defcustom newsticker-show-all-news-elements nil "Show all news elements." :type 'boolean - ;;:set 'newsticker--set-customvar + ;;:set #'newsticker--set-customvar :group 'newsticker-plainview) ;; ====================================================================== @@ -386,51 +386,45 @@ images." (defvar newsticker-mode-map (let ((map (make-keymap))) - (define-key map "sO" 'newsticker-show-old-items) - (define-key map "hO" 'newsticker-hide-old-items) - (define-key map "sa" 'newsticker-show-all-desc) - (define-key map "ha" 'newsticker-hide-all-desc) - (define-key map "sf" 'newsticker-show-feed-desc) - (define-key map "hf" 'newsticker-hide-feed-desc) - (define-key map "so" 'newsticker-show-old-item-desc) - (define-key map "ho" 'newsticker-hide-old-item-desc) - (define-key map "sn" 'newsticker-show-new-item-desc) - (define-key map "hn" 'newsticker-hide-new-item-desc) - (define-key map "se" 'newsticker-show-entry) - (define-key map "he" 'newsticker-hide-entry) - (define-key map "sx" 'newsticker-show-extra) - (define-key map "hx" 'newsticker-hide-extra) - - (define-key map [?\S-\ ] 'scroll-down-command) - (define-key map " " 'scroll-up-command) - (define-key map "q" 'newsticker-close-buffer) - (define-key map "p" 'newsticker-previous-item) - (define-key map "P" 'newsticker-previous-new-item) - (define-key map "F" 'newsticker-previous-feed) - (define-key map "\t" 'newsticker-next-item) - (define-key map "n" 'newsticker-next-item) - (define-key map "N" 'newsticker-next-new-item) - (define-key map "f" 'newsticker-next-feed) - (define-key map "M" 'newsticker-mark-all-items-as-read) - (define-key map "m" - 'newsticker-mark-all-items-at-point-as-read-and-redraw) - (define-key map "o" - 'newsticker-mark-item-at-point-as-read) - (define-key map "O" - 'newsticker-mark-all-items-at-point-as-read) - (define-key map "G" 'newsticker-get-all-news) - (define-key map "g" 'newsticker-get-news-at-point) - (define-key map "u" 'newsticker-buffer-update) - (define-key map "U" 'newsticker-buffer-force-update) - (define-key map "a" 'newsticker-add-url) - - (define-key map "i" - 'newsticker-mark-item-at-point-as-immortal) - - (define-key map "xf" - 'newsticker-toggle-auto-narrow-to-feed) - (define-key map "xi" - 'newsticker-toggle-auto-narrow-to-item) + (define-key map "sO" #'newsticker-show-old-items) + (define-key map "hO" #'newsticker-hide-old-items) + (define-key map "sa" #'newsticker-show-all-desc) + (define-key map "ha" #'newsticker-hide-all-desc) + (define-key map "sf" #'newsticker-show-feed-desc) + (define-key map "hf" #'newsticker-hide-feed-desc) + (define-key map "so" #'newsticker-show-old-item-desc) + (define-key map "ho" #'newsticker-hide-old-item-desc) + (define-key map "sn" #'newsticker-show-new-item-desc) + (define-key map "hn" #'newsticker-hide-new-item-desc) + (define-key map "se" #'newsticker-show-entry) + (define-key map "he" #'newsticker-hide-entry) + (define-key map "sx" #'newsticker-show-extra) + (define-key map "hx" #'newsticker-hide-extra) + + (define-key map [?\S-\ ] #'scroll-down-command) + (define-key map " " #'scroll-up-command) + (define-key map "q" #'newsticker-close-buffer) + (define-key map "p" #'newsticker-previous-item) + (define-key map "P" #'newsticker-previous-new-item) + (define-key map "F" #'newsticker-previous-feed) + (define-key map "\t" #'newsticker-next-item) + (define-key map "n" #'newsticker-next-item) + (define-key map "N" #'newsticker-next-new-item) + (define-key map "f" #'newsticker-next-feed) + (define-key map "M" #'newsticker-mark-all-items-as-read) + (define-key map "m" #'newsticker-mark-all-items-at-point-as-read-and-redraw) + (define-key map "o" #'newsticker-mark-item-at-point-as-read) + (define-key map "O" #'newsticker-mark-all-items-at-point-as-read) + (define-key map "G" #'newsticker-get-all-news) + (define-key map "g" #'newsticker-get-news-at-point) + (define-key map "u" #'newsticker-buffer-update) + (define-key map "U" #'newsticker-buffer-force-update) + (define-key map "a" #'newsticker-add-url) + + (define-key map "i" #'newsticker-mark-item-at-point-as-immortal) + + (define-key map "xf" #'newsticker-toggle-auto-narrow-to-feed) + (define-key map "xi" #'newsticker-toggle-auto-narrow-to-item) ;; Bind menu to mouse. (define-key map [down-mouse-3] newsticker-menu) @@ -479,11 +473,11 @@ images." ;; maps for the clickable portions (defvar newsticker--url-keymap (let ((map (make-sparse-keymap))) - (define-key map [mouse-1] 'newsticker-mouse-browse-url) - (define-key map [mouse-2] 'newsticker-mouse-browse-url) - (define-key map "\n" 'newsticker-browse-url) - (define-key map "\C-m" 'newsticker-browse-url) - (define-key map [(control return)] 'newsticker-handle-url) + (define-key map [mouse-1] #'newsticker-mouse-browse-url) + (define-key map [mouse-2] #'newsticker-mouse-browse-url) + (define-key map "\n" #'newsticker-browse-url) + (define-key map "\C-m" #'newsticker-browse-url) + (define-key map [(control return)] #'newsticker-handle-url) map) "Key map for click-able headings in the newsticker buffer.") @@ -980,7 +974,7 @@ not get changed." (let* (pos1 pos2 (inhibit-read-only t) inv-prop org-inv-prop - is-invisible) + ) ;; is-invisible (newsticker--buffer-beginning-of-item) (newsticker--buffer-goto '(desc)) (setq pos1 (max (point-min) (1- (point)))) @@ -1009,7 +1003,7 @@ not get changed." (let* (pos1 pos2 (inhibit-read-only t) inv-prop org-inv-prop - is-invisible) + ) ;; is-invisible (newsticker--buffer-beginning-of-item) (newsticker--buffer-goto '(desc)) (setq pos1 (max (point-min) (1- (point)))) @@ -1147,7 +1141,7 @@ If VALUE is nil, auto-narrowing is turned off, otherwise it is turned on." (setq index-alist (list feed-list))) index-alist))) -(defun newsticker--imenu-goto (name pos &rest args) +(defun newsticker--imenu-goto (_name pos &rest _args) "Go to item NAME at position POS and show item. ARGS are ignored." (goto-char pos) @@ -1236,6 +1230,9 @@ item-retrieval time is added as well." ;; insert the description (newsticker--buffer-do-insert-text item 'desc feed-name-symbol)) +(defvar w3m-fill-column) +(defvar w3-maximum-line-length) + (defun newsticker--buffer-do-insert-text (item type feed-name-symbol) "Actually insert contents of news item, format it, render it and all that. ITEM is a news item, TYPE tells which part of the item shall be inserted, diff --git a/lisp/net/newst-reader.el b/lisp/net/newst-reader.el index b188bd4589e..40e304402ad 100644 --- a/lisp/net/newst-reader.el +++ b/lisp/net/newst-reader.el @@ -1,4 +1,4 @@ -;;; newst-reader.el --- Generic RSS reader functions. +;;; newst-reader.el --- Generic RSS reader functions. -*- lexical-binding: t; -*- ;; Copyright (C) 2003-2021 Free Software Foundation, Inc. @@ -94,7 +94,7 @@ done." (const :tag "Right" right) (const :tag "Center" center) (const :tag "Full" full)) - :set 'newsticker--set-customvar-formatting + :set #'newsticker--set-customvar-formatting :group 'newsticker-reader) (defcustom newsticker-use-full-width @@ -103,7 +103,7 @@ done." If non-nil newsticker sets `fill-column' so that the whole window is used when filling. See also `newsticker-justification'." :type 'boolean - :set 'newsticker--set-customvar-formatting + :set #'newsticker--set-customvar-formatting :group 'newsticker-reader) (defcustom newsticker-html-renderer @@ -122,7 +122,7 @@ htmlr if this option is set." (const :tag "w3" w3-region) (const :tag "w3m" w3m-region) (const :tag "htmlr" newsticker-htmlr-render)) - :set 'newsticker--set-customvar-formatting + :set #'newsticker--set-customvar-formatting :group 'newsticker-reader) (defcustom newsticker-date-format @@ -130,7 +130,7 @@ htmlr if this option is set." "Format for the date part in item and feed lines. See `format-time-string' for a list of valid specifiers." :type 'string - :set 'newsticker--set-customvar-formatting + :set #'newsticker--set-customvar-formatting :group 'newsticker-reader) (defgroup newsticker-faces nil diff --git a/lisp/net/newst-ticker.el b/lisp/net/newst-ticker.el index 275c91a36ea..2f764708701 100644 --- a/lisp/net/newst-ticker.el +++ b/lisp/net/newst-ticker.el @@ -1,4 +1,4 @@ -;; newst-ticker.el --- mode line ticker for newsticker. +;; newst-ticker.el --- mode line ticker for newsticker. -*- lexical-binding: t; -*- ;; Copyright (C) 2003-2021 Free Software Foundation, Inc. @@ -83,7 +83,7 @@ smooth display (see `newsticker-scroll-smoothly') a value of 0.3 seems reasonable. For non-smooth display a value of 10 is a good starting point." :type 'number - :set 'newsticker--set-customvar-ticker + :set #'newsticker--set-customvar-ticker :group 'newsticker-ticker) (defcustom newsticker-scroll-smoothly @@ -104,7 +104,7 @@ at all. If you change `newsticker-scroll-smoothly' you should also change If t the echo area will not show immortal items. See also `newsticker-hide-old-items-in-echo-area'." :type 'boolean - :set 'newsticker--set-customvar-ticker + :set #'newsticker--set-customvar-ticker :group 'newsticker-ticker) (defcustom newsticker-hide-old-items-in-echo-area @@ -113,7 +113,7 @@ If t the echo area will not show immortal items. See also If t the echo area will show only new items, i.e. only items which have been added between the last two retrievals." :type 'boolean - :set 'newsticker--set-customvar-ticker + :set #'newsticker--set-customvar-ticker :group 'newsticker-ticker) (defcustom newsticker-hide-obsolete-items-in-echo-area @@ -122,7 +122,7 @@ been added between the last two retrievals." If t the echo area will not show obsolete items. See also `newsticker-hide-old-items-in-echo-area'." :type 'boolean - :set 'newsticker--set-customvar-ticker + :set #'newsticker--set-customvar-ticker :group 'newsticker-ticker) (defun newsticker--display-tick () @@ -205,7 +205,7 @@ running already." (setq newsticker--ticker-timer (run-at-time newsticker-ticker-interval newsticker-ticker-interval - 'newsticker--display-tick)))) + #'newsticker--display-tick)))) (defun newsticker-stop-ticker () "Stop newsticker's ticker (but not the news retrieval)." diff --git a/lisp/net/newst-treeview.el b/lisp/net/newst-treeview.el index 2e207be20f9..d778cc17615 100644 --- a/lisp/net/newst-treeview.el +++ b/lisp/net/newst-treeview.el @@ -52,86 +52,73 @@ (defface newsticker-treeview-face '((((class color) (background dark)) :foreground "white") (((class color) (background light)) :foreground "black")) - "Face for newsticker tree." - :group 'newsticker-treeview) + "Face for newsticker tree.") (defface newsticker-treeview-new-face '((t :inherit newsticker-treeview-face :weight bold)) - "Face for newsticker tree." - :group 'newsticker-treeview) + "Face for newsticker tree.") (defface newsticker-treeview-old-face '((t :inherit newsticker-treeview-face)) - "Face for newsticker tree." - :group 'newsticker-treeview) + "Face for newsticker tree.") (defface newsticker-treeview-immortal-face '((default :inherit newsticker-treeview-face :slant italic) (((class color) (background dark)) :foreground "orange") (((class color) (background light)) :foreground "blue")) - "Face for newsticker tree." - :group 'newsticker-treeview) + "Face for newsticker tree.") (defface newsticker-treeview-obsolete-face '((t :inherit newsticker-treeview-face :strike-through t)) - "Face for newsticker tree." - :group 'newsticker-treeview) + "Face for newsticker tree.") (defface newsticker-treeview-selection-face '((((class color) (background dark)) :background "#4444aa") (((class color) (background light)) :background "#bbbbff")) - "Face for newsticker selection." - :group 'newsticker-treeview) + "Face for newsticker selection.") (defcustom newsticker-treeview-date-format "%d.%m.%y, %H:%M" "Format for the date column in the treeview list buffer. See `format-time-string' for a list of valid specifiers." :version "25.1" - :type 'string - :group 'newsticker-treeview) + :type 'string) (defcustom newsticker-treeview-own-frame nil "Decides whether newsticker treeview creates and uses its own frame." - :type 'boolean - :group 'newsticker-treeview) + :type 'boolean) (defcustom newsticker-treeview-treewindow-width 30 "Width of tree window in treeview layout. See also `newsticker-treeview-listwindow-height'." - :type 'integer - :group 'newsticker-treeview) + :type 'integer) (defcustom newsticker-treeview-listwindow-height 10 "Height of list window in treeview layout. See also `newsticker-treeview-treewindow-width'." - :type 'integer - :group 'newsticker-treeview) + :type 'integer) (defcustom newsticker-treeview-automatically-mark-displayed-items-as-old t "Decides whether to automatically mark displayed items as old. If t an item is marked as old as soon as it is displayed. This applies to newsticker only." - :type 'boolean - :group 'newsticker-treeview) + :type 'boolean) (defcustom newsticker-treeview-use-feed-name-from-url-list-in-treeview t "Use the feed names from 'newsticker-url-list' for display in treeview." :version "28.1" - :type 'boolean - :group 'newsticker-treeview) + :type 'boolean) (defcustom newsticker-treeview-use-feed-name-from-url-list-in-itemview t "Use feed names from 'newsticker-url-list' in itemview." :version "28.1" - :type 'boolean - :group 'newsticker-treeview) + :type 'boolean) (defvar newsticker-groups '("Feeds") @@ -166,14 +153,16 @@ Example: (\"Topmost group\" \"feed1\" (\"subgroup1\" \"feed 2\") (defvar newsticker--treeview-feed-tree nil) (defvar newsticker--treeview-vfeed-tree nil) +(declare-function newsticker-handle-url "newst-plainview" ()) + ;; maps for the clickable portions (defvar newsticker--treeview-url-keymap (let ((map (make-sparse-keymap 'newsticker--treeview-url-keymap))) - (define-key map [mouse-1] 'newsticker-treeview-mouse-browse-url) - (define-key map [mouse-2] 'newsticker-treeview-mouse-browse-url) - (define-key map "\n" 'newsticker-treeview-browse-url) - (define-key map "\C-m" 'newsticker-treeview-browse-url) - (define-key map [(control return)] 'newsticker-handle-url) + (define-key map [mouse-1] #'newsticker-treeview-mouse-browse-url) + (define-key map [mouse-2] #'newsticker-treeview-mouse-browse-url) + (define-key map "\n" #'newsticker-treeview-browse-url) + (define-key map "\C-m" #'newsticker-treeview-browse-url) + (define-key map [(control return)] #'newsticker-handle-url) map) "Key map for click-able headings in the newsticker treeview buffers.") @@ -342,9 +331,9 @@ If string SHOW-FEED is non-nil it is shown in the item string." (replace-match " ")) (let ((map (make-sparse-keymap))) (dolist (key'([mouse-1] [mouse-3])) - (define-key map key 'newsticker-treeview-tree-click)) - (define-key map "\n" 'newsticker-treeview-show-item) - (define-key map "\C-m" 'newsticker-treeview-show-item) + (define-key map key #'newsticker-treeview-tree-click)) + (define-key map "\n" #'newsticker-treeview-show-item) + (define-key map "\C-m" #'newsticker-treeview-show-item) (add-text-properties pos1 (point-max) (list :nt-item item :nt-feed feed @@ -626,9 +615,9 @@ If CLEAR-BUFFER is non-nil the list buffer is completely erased." (defvar newsticker-treeview-list-sort-button-map (let ((map (make-sparse-keymap))) (define-key map [header-line mouse-1] - 'newsticker--treeview-list-sort-by-column) + #'newsticker--treeview-list-sort-by-column) (define-key map [header-line mouse-2] - 'newsticker--treeview-list-sort-by-column) + #'newsticker--treeview-list-sort-by-column) map) "Local keymap for newsticker treeview list window sort buttons.") @@ -960,9 +949,9 @@ arguments NT-ID, FEED, VFEED and TOOLTIP are added as properties." (if (and num-new (> num-new 0)) (setq face 'newsticker-treeview-new-face)) (dolist (key '([mouse-1] [mouse-3])) - (define-key map key 'newsticker-treeview-tree-click)) - (define-key map "\n" 'newsticker-treeview-tree-do-click) - (define-key map "\C-m" 'newsticker-treeview-tree-do-click) + (define-key map key #'newsticker-treeview-tree-click)) + (define-key map "\n" #'newsticker-treeview-tree-do-click) + (define-key map "\C-m" #'newsticker-treeview-tree-do-click) (propertize tag 'face face 'keymap map :nt-id nt-id :nt-feed feed @@ -2029,37 +2018,37 @@ Return t if groups have changed, nil otherwise." (defvar newsticker-treeview-mode-map (let ((map (make-sparse-keymap 'newsticker-treeview-mode-map))) - (define-key map " " 'newsticker-treeview-next-page) - (define-key map "a" 'newsticker-add-url) - (define-key map "b" 'newsticker-treeview-browse-url-item) - (define-key map "c" 'newsticker-treeview-customize-current-feed) - (define-key map "F" 'newsticker-treeview-prev-feed) - (define-key map "f" 'newsticker-treeview-next-feed) - (define-key map "g" 'newsticker-treeview-get-news) - (define-key map "G" 'newsticker-get-all-news) - (define-key map "i" 'newsticker-treeview-toggle-item-immortal) - (define-key map "j" 'newsticker-treeview-jump) - (define-key map "n" 'newsticker-treeview-next-item) - (define-key map "N" 'newsticker-treeview-next-new-or-immortal-item) - (define-key map "O" 'newsticker-treeview-mark-list-items-old) - (define-key map "o" 'newsticker-treeview-mark-item-old) - (define-key map "p" 'newsticker-treeview-prev-item) - (define-key map "P" 'newsticker-treeview-prev-new-or-immortal-item) - (define-key map "q" 'newsticker-treeview-quit) - (define-key map "S" 'newsticker-treeview-save-item) - (define-key map "s" 'newsticker-treeview-save) - (define-key map "u" 'newsticker-treeview-update) - (define-key map "v" 'newsticker-treeview-browse-url) - ;;(define-key map "\n" 'newsticker-treeview-scroll-item) - ;;(define-key map "\C-m" 'newsticker-treeview-scroll-item) - (define-key map "\M-m" 'newsticker-group-move-feed) - (define-key map "\M-a" 'newsticker-group-add-group) - (define-key map "\M-d" 'newsticker-group-delete-group) - (define-key map "\M-r" 'newsticker-group-rename-group) - (define-key map [M-down] 'newsticker-group-shift-feed-down) - (define-key map [M-up] 'newsticker-group-shift-feed-up) - (define-key map [M-S-down] 'newsticker-group-shift-group-down) - (define-key map [M-S-up] 'newsticker-group-shift-group-up) + (define-key map " " #'newsticker-treeview-next-page) + (define-key map "a" #'newsticker-add-url) + (define-key map "b" #'newsticker-treeview-browse-url-item) + (define-key map "c" #'newsticker-treeview-customize-current-feed) + (define-key map "F" #'newsticker-treeview-prev-feed) + (define-key map "f" #'newsticker-treeview-next-feed) + (define-key map "g" #'newsticker-treeview-get-news) + (define-key map "G" #'newsticker-get-all-news) + (define-key map "i" #'newsticker-treeview-toggle-item-immortal) + (define-key map "j" #'newsticker-treeview-jump) + (define-key map "n" #'newsticker-treeview-next-item) + (define-key map "N" #'newsticker-treeview-next-new-or-immortal-item) + (define-key map "O" #'newsticker-treeview-mark-list-items-old) + (define-key map "o" #'newsticker-treeview-mark-item-old) + (define-key map "p" #'newsticker-treeview-prev-item) + (define-key map "P" #'newsticker-treeview-prev-new-or-immortal-item) + (define-key map "q" #'newsticker-treeview-quit) + (define-key map "S" #'newsticker-treeview-save-item) + (define-key map "s" #'newsticker-treeview-save) + (define-key map "u" #'newsticker-treeview-update) + (define-key map "v" #'newsticker-treeview-browse-url) + ;;(define-key map "\n" #'newsticker-treeview-scroll-item) + ;;(define-key map "\C-m" #'newsticker-treeview-scroll-item) + (define-key map "\M-m" #'newsticker-group-move-feed) + (define-key map "\M-a" #'newsticker-group-add-group) + (define-key map "\M-d" #'newsticker-group-delete-group) + (define-key map "\M-r" #'newsticker-group-rename-group) + (define-key map [M-down] #'newsticker-group-shift-feed-down) + (define-key map [M-up] #'newsticker-group-shift-feed-up) + (define-key map [M-S-down] #'newsticker-group-shift-group-down) + (define-key map [M-S-up] #'newsticker-group-shift-group-up) map) "Mode map for newsticker treeview.") diff --git a/lisp/net/puny.el b/lisp/net/puny.el index 1cdefc08f02..42a7e796798 100644 --- a/lisp/net/puny.el +++ b/lisp/net/puny.el @@ -37,7 +37,7 @@ For instance, \"fƛf.org\" => \"xn--ff-2sa.org\"." ;; add a check first to avoid doing unnecessary work. (if (string-match "\\`[[:ascii:]]+\\'" domain) domain - (mapconcat 'puny-encode-string (split-string domain "[.]") "."))) + (mapconcat #'puny-encode-string (split-string domain "[.]") "."))) (defun puny-encode-string (string) "Encode STRING according to the IDNA/punycode algorithm. @@ -57,7 +57,7 @@ For instance, \"bĂŒcher\" => \"xn--bcher-kva\"." (defun puny-decode-domain (domain) "Decode DOMAIN according to the IDNA/punycode algorithm. For instance, \"xn--ff-2sa.org\" => \"fƛf.org\"." - (mapconcat 'puny-decode-string (split-string domain "[.]") ".")) + (mapconcat #'puny-decode-string (split-string domain "[.]") ".")) (defun puny-decode-string (string) "Decode an IDNA/punycode-encoded string. diff --git a/lisp/net/quickurl.el b/lisp/net/quickurl.el index ab1f43f552b..2574c8cb63e 100644 --- a/lisp/net/quickurl.el +++ b/lisp/net/quickurl.el @@ -1,4 +1,4 @@ -;;; quickurl.el --- insert a URL based on text at point in buffer +;;; quickurl.el --- insert a URL based on text at point in buffer -*- lexical-binding: t; -*- ;; Copyright (C) 1999-2021 Free Software Foundation, Inc. @@ -97,23 +97,19 @@ (locate-user-emacs-file "quickurls" ".quickurls") "File that contains the URL list." :version "24.4" ; added locate-user-emacs-file - :type 'file - :group 'quickurl) + :type 'file) (defcustom quickurl-format-function #'quickurl-format-url "Function to format the URL before insertion into the current buffer." - :type 'function - :group 'quickurl) + :type 'function) (defcustom quickurl-sort-function #'quickurl-sort-urls "Function to sort the URL list." - :type 'function - :group 'quickurl) + :type 'function) (defcustom quickurl-grab-lookup-function #'current-word "Function to grab the thing to lookup." - :type 'function - :group 'quickurl) + :type 'function) (defun quickurl--assoc-function (key alist) "Default function for `quickurl-assoc-function'." @@ -122,31 +118,26 @@ (defcustom quickurl-assoc-function #'quickurl--assoc-function "Function to use for alist lookup into `quickurl-urls'." :version "26.1" ; was the obsolete assoc-ignore-case - :type 'function - :group 'quickurl) + :type 'function) (defcustom quickurl-completion-ignore-case t "Should `quickurl-ask' ignore case when doing the input lookup?" - :type 'boolean - :group 'quickurl) + :type 'boolean) (defcustom quickurl-prefix ";; -*- lisp -*-\n\n" "Text to write to `quickurl-url-file' before writing the URL list." - :type 'string - :group 'quickurl) + :type 'string) (defcustom quickurl-postfix "" "Text to write to `quickurl-url-file' after writing the URL list. See the constant `quickurl-reread-hook-postfix' for some example text that could be used here." - :type 'string - :group 'quickurl) + :type 'string) (defcustom quickurl-list-mode-hook nil "Hooks for `quickurl-list-mode'." - :type 'hook - :group 'quickurl) + :type 'hook) ;; Constants. diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index c80cd49c006..938fadfed74 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -293,7 +293,7 @@ The following replacements are made: Setting this alone will not affect the prompt; use either M-x customize or also call `rcirc-update-prompt'." :type 'string - :set 'rcirc-set-changed + :set #'rcirc-set-changed :initialize 'custom-initialize-default) (defcustom rcirc-keywords nil diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el index ad271679618..94db318c1b0 100644 --- a/lisp/net/secrets.el +++ b/lisp/net/secrets.el @@ -643,7 +643,7 @@ starting with a colon. Example: The object labels of the found items are returned as list." (mapcar (lambda (item-path) (secrets-get-item-property item-path "Label")) - (apply 'secrets-search-item-paths collection attributes))) + (apply #'secrets-search-item-paths collection attributes))) (defun secrets-create-item (collection item password &rest attributes) "Create a new item in COLLECTION with label ITEM and password PASSWORD. @@ -780,9 +780,9 @@ ITEM can also be an object path, which is used if contained in COLLECTION." (defvar secrets-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent map (make-composed-keymap special-mode-map widget-keymap)) - (define-key map "n" 'next-line) - (define-key map "p" 'previous-line) - (define-key map "z" 'kill-current-buffer) + (define-key map "n" #'next-line) + (define-key map "p" #'previous-line) + (define-key map "z" #'kill-current-buffer) map) "Keymap used in `secrets-mode' buffers.") @@ -859,7 +859,7 @@ to their attributes." ;; padding is needed to format attribute names. (padding (apply - 'max + #'max (cons (1+ (length "password")) (mapcar diff --git a/lisp/net/shr-color.el b/lisp/net/shr-color.el index ac1f701fd37..eb78a259a8c 100644 --- a/lisp/net/shr-color.el +++ b/lisp/net/shr-color.el @@ -36,14 +36,12 @@ (defcustom shr-color-visible-luminance-min 40 "Minimum luminance distance between two colors to be considered visible. Must be between 0 and 100." - :group 'shr-color :type 'number) (defcustom shr-color-visible-distance-min 5 "Minimum color distance between two colors to be considered visible. This value is used to compare result for `ciede2000'. It's an absolute value without any unit." - :group 'shr-color :type 'integer) (defconst shr-color-html-colors-alist @@ -332,8 +330,8 @@ color will be adapted to be visible on BG." (if (or (null fg-norm) (null bg-norm)) (list bg fg) - (let* ((fg-lab (apply 'color-srgb-to-lab fg-norm)) - (bg-lab (apply 'color-srgb-to-lab bg-norm)) + (let* ((fg-lab (apply #'color-srgb-to-lab fg-norm)) + (bg-lab (apply #'color-srgb-to-lab bg-norm)) ;; Compute color distance using CIE DE 2000 (fg-bg-distance (color-cie-de2000 fg-lab bg-lab)) ;; Compute luminance distance (subtract L component) @@ -351,12 +349,12 @@ color will be adapted to be visible on BG." (list (if fixed-background bg - (apply 'format "#%02x%02x%02x" + (apply #'format "#%02x%02x%02x" (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) - (apply 'color-lab-to-srgb bg-lab)))) - (apply 'format "#%02x%02x%02x" + (apply #'color-lab-to-srgb bg-lab)))) + (apply #'format "#%02x%02x%02x" (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) - (apply 'color-lab-to-srgb fg-lab)))))))))) + (apply #'color-lab-to-srgb fg-lab)))))))))) (provide 'shr-color) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 0e89999b756..c122a19e90c 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -220,20 +220,20 @@ and other things: (defvar shr-map (let ((map (make-sparse-keymap))) - (define-key map "a" 'shr-show-alt-text) - (define-key map "i" 'shr-browse-image) - (define-key map "z" 'shr-zoom-image) - (define-key map [?\t] 'shr-next-link) - (define-key map [?\M-\t] 'shr-previous-link) + (define-key map "a" #'shr-show-alt-text) + (define-key map "i" #'shr-browse-image) + (define-key map "z" #'shr-zoom-image) + (define-key map [?\t] #'shr-next-link) + (define-key map [?\M-\t] #'shr-previous-link) (define-key map [follow-link] 'mouse-face) - (define-key map [mouse-2] 'shr-browse-url) - (define-key map [C-down-mouse-1] 'shr-mouse-browse-url-new-window) - (define-key map "I" 'shr-insert-image) - (define-key map "w" 'shr-maybe-probe-and-copy-url) - (define-key map "u" 'shr-maybe-probe-and-copy-url) - (define-key map "v" 'shr-browse-url) - (define-key map "O" 'shr-save-contents) - (define-key map "\r" 'shr-browse-url) + (define-key map [mouse-2] #'shr-browse-url) + (define-key map [C-down-mouse-1] #'shr-mouse-browse-url-new-window) + (define-key map "I" #'shr-insert-image) + (define-key map "w" #'shr-maybe-probe-and-copy-url) + (define-key map "u" #'shr-maybe-probe-and-copy-url) + (define-key map "v" #'shr-browse-url) + (define-key map "O" #'shr-save-contents) + (define-key map "\r" #'shr-browse-url) map)) (defvar shr-image-map diff --git a/lisp/net/sieve-mode.el b/lisp/net/sieve-mode.el index 7bc1d16122d..966f0f056bd 100644 --- a/lisp/net/sieve-mode.el +++ b/lisp/net/sieve-mode.el @@ -139,9 +139,9 @@ (defvar sieve-mode-map (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-l" 'sieve-upload) - (define-key map "\C-c\C-c" 'sieve-upload-and-kill) - (define-key map "\C-c\C-m" 'sieve-manage) + (define-key map "\C-c\C-l" #'sieve-upload) + (define-key map "\C-c\C-c" #'sieve-upload-and-kill) + (define-key map "\C-c\C-m" #'sieve-manage) map) "Key map used in sieve mode.") diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index 3cc5569b55c..821ef4af8e0 100644 --- a/lisp/net/soap-client.el +++ b/lisp/net/soap-client.el @@ -10,6 +10,7 @@ ;; Package: soap-client ;; Homepage: https://github.com/alex-hhh/emacs-soap-client ;; Package-Requires: ((cl-lib "0.6.1")) +;;FIXME: Put in `Package-Requires:' the Emacs version we expect. ;; This file is part of GNU Emacs. @@ -771,6 +772,8 @@ This is a specialization of `soap-decode-type' for (Array (soap-decode-array node)))))) (defalias 'soap-type-of + ;; FIXME: Once we drop support for Emacs<25, use generic functions + ;; via `cl-defmethod' instead of our own ad-hoc version of it. (if (eq 'soap-xs-basic-type (type-of (make-soap-xs-basic-type))) ;; `type-of' in Emacs ≄ 26 already does what we need. #'type-of @@ -1263,7 +1266,7 @@ See also `soap-wsdl-resolve-references'." (soap-l2wk (xml-node-name node))) (setf (soap-xs-simple-type-base type) - (mapcar 'soap-l2fq + (mapcar #'soap-l2fq (split-string (or (xml-get-attribute-or-nil node 'memberTypes) "")))) @@ -1343,7 +1346,7 @@ See also `soap-wsdl-resolve-references'." (soap-validate-xs-basic-type value base)))) (error (push (cadr error-object) messages)))) (when messages - (error (mapconcat 'identity (nreverse messages) "; and: ")))) + (error (mapconcat #'identity (nreverse messages) "; and: ")))) (cl-labels ((fail-with-message (format value) (push (format format value) messages) (throw 'invalid nil))) @@ -2345,8 +2348,8 @@ See also `soap-resolve-references' and (when (= (length (soap-operation-parameter-order operation)) 0) (setf (soap-operation-parameter-order operation) - (mapcar 'car (soap-message-parts - (cdr (soap-operation-input operation)))))) + (mapcar #'car (soap-message-parts + (cdr (soap-operation-input operation)))))) (setf (soap-operation-parameter-order operation) (mapcar (lambda (p) @@ -2391,13 +2394,13 @@ See also `soap-wsdl-resolve-references'." ;; Install resolvers for our types (progn (put (soap-type-of (make-soap-message)) 'soap-resolve-references - 'soap-resolve-references-for-message) + #'soap-resolve-references-for-message) (put (soap-type-of (make-soap-operation)) 'soap-resolve-references - 'soap-resolve-references-for-operation) + #'soap-resolve-references-for-operation) (put (soap-type-of (make-soap-binding)) 'soap-resolve-references - 'soap-resolve-references-for-binding) + #'soap-resolve-references-for-binding) (put (soap-type-of (make-soap-port)) 'soap-resolve-references - 'soap-resolve-references-for-port)) + #'soap-resolve-references-for-port)) (defun soap-wsdl-resolve-references (wsdl) "Resolve all references inside the WSDL structure. @@ -2511,7 +2514,7 @@ Build on WSDL if it is provided." (soap-wsdl-resolve-references (soap-parse-wsdl xml wsdl)) wsdl)) -(defalias 'soap-load-wsdl-from-url 'soap-load-wsdl) +(defalias 'soap-load-wsdl-from-url #'soap-load-wsdl) (defun soap-parse-wsdl-phase-validate-node (node) "Assert that NODE is valid." @@ -2884,7 +2887,7 @@ decode function to perform the actual decoding." (if (fboundp 'define-error) (define-error 'soap-error "SOAP error") - ;; Support older Emacs versions that do not have define-error, so + ;; Support Emacs<24.4 that do not have define-error, so ;; that soap-client can remain unchanged in GNU ELPA. (put 'soap-error 'error-conditions @@ -3123,8 +3126,7 @@ http://schemas.xmlsoap.org/soap/encoding/\"\n")) (defcustom soap-debug nil "When t, enable some debugging facilities." - :type 'boolean - :group 'soap-client) + :type 'boolean) (defun soap-find-port (wsdl service) "Return the WSDL port having SERVICE name. diff --git a/lisp/net/soap-inspect.el b/lisp/net/soap-inspect.el index 9d4e440719d..6f9ce6a2d69 100644 --- a/lisp/net/soap-inspect.el +++ b/lisp/net/soap-inspect.el @@ -109,7 +109,7 @@ soap-xs-attribute objects." This is a specialization of `soap-sample-value' for `soap-xs-simple-type' objects." (append - (mapcar 'soap-sample-value-for-xs-attribute + (mapcar #'soap-sample-value-for-xs-attribute (soap-xs-type-attributes type)) (cond ((soap-xs-simple-type-enumeration type) @@ -143,7 +143,7 @@ This is a specialization of `soap-sample-value' for This is a specialization of `soap-sample-value' for `soap-xs-complex-type' objects." (append - (mapcar 'soap-sample-value-for-xs-attribute + (mapcar #'soap-sample-value-for-xs-attribute (soap-xs-type-attributes type)) (cl-case (soap-xs-complex-type-indicator type) (array @@ -176,31 +176,31 @@ This is a specialization of `soap-sample-value' for ;; Install soap-sample-value methods for our types (put (soap-type-of (make-soap-xs-basic-type)) 'soap-sample-value - 'soap-sample-value-for-xs-basic-type) + #'soap-sample-value-for-xs-basic-type) (put (soap-type-of (make-soap-xs-element)) 'soap-sample-value - 'soap-sample-value-for-xs-element) + #'soap-sample-value-for-xs-element) (put (soap-type-of (make-soap-xs-attribute)) 'soap-sample-value - 'soap-sample-value-for-xs-attribute) + #'soap-sample-value-for-xs-attribute) (put (soap-type-of (make-soap-xs-attribute)) 'soap-sample-value - 'soap-sample-value-for-xs-attribute-group) + #'soap-sample-value-for-xs-attribute-group) (put (soap-type-of (make-soap-xs-simple-type)) 'soap-sample-value - 'soap-sample-value-for-xs-simple-type) + #'soap-sample-value-for-xs-simple-type) (put (soap-type-of (make-soap-xs-complex-type)) 'soap-sample-value - 'soap-sample-value-for-xs-complex-type) + #'soap-sample-value-for-xs-complex-type) (put (soap-type-of (make-soap-message)) 'soap-sample-value - 'soap-sample-value-for-message)) + #'soap-sample-value-for-message)) @@ -437,7 +437,7 @@ TYPE is a `soap-xs-complex-type'." (funcall (list 'soap-invoke '*WSDL* "SomeService" (soap-element-name operation)))) (let ((sample-invocation - (append funcall (mapcar 'cdr sample-message-value)))) + (append funcall (mapcar #'cdr sample-message-value)))) (pp sample-invocation (current-buffer))))) (defun soap-inspect-port-type (port-type) @@ -460,7 +460,7 @@ TYPE is a `soap-xs-complex-type'." collect o)) op-name-width) - (setq operations (sort operations 'string<)) + (setq operations (sort operations #'string<)) (setq op-name-width (cl-loop for o in operations maximizing (length o))) @@ -504,39 +504,39 @@ TYPE is a `soap-xs-complex-type'." ;; Install the soap-inspect methods for our types (put (soap-type-of (make-soap-xs-basic-type)) 'soap-inspect - 'soap-inspect-xs-basic-type) + #'soap-inspect-xs-basic-type) (put (soap-type-of (make-soap-xs-element)) 'soap-inspect - 'soap-inspect-xs-element) + #'soap-inspect-xs-element) (put (soap-type-of (make-soap-xs-simple-type)) 'soap-inspect - 'soap-inspect-xs-simple-type) + #'soap-inspect-xs-simple-type) (put (soap-type-of (make-soap-xs-complex-type)) 'soap-inspect - 'soap-inspect-xs-complex-type) + #'soap-inspect-xs-complex-type) (put (soap-type-of (make-soap-xs-attribute)) 'soap-inspect - 'soap-inspect-xs-attribute) + #'soap-inspect-xs-attribute) (put (soap-type-of (make-soap-xs-attribute-group)) 'soap-inspect - 'soap-inspect-xs-attribute-group) + #'soap-inspect-xs-attribute-group) (put (soap-type-of (make-soap-message)) 'soap-inspect - 'soap-inspect-message) + #'soap-inspect-message) (put (soap-type-of (make-soap-operation)) 'soap-inspect - 'soap-inspect-operation) + #'soap-inspect-operation) (put (soap-type-of (make-soap-port-type)) 'soap-inspect - 'soap-inspect-port-type) + #'soap-inspect-port-type) (put (soap-type-of (make-soap-binding)) 'soap-inspect - 'soap-inspect-binding) + #'soap-inspect-binding) (put (soap-type-of (make-soap-port)) 'soap-inspect - 'soap-inspect-port) + #'soap-inspect-port) (put (soap-type-of (soap-make-wsdl "origin")) 'soap-inspect - 'soap-inspect-wsdl)) + #'soap-inspect-wsdl)) (provide 'soap-inspect) ;;; soap-inspect.el ends here diff --git a/lisp/net/telnet.el b/lisp/net/telnet.el index 44f535f01c9..bb65ecaa981 100644 --- a/lisp/net/telnet.el +++ b/lisp/net/telnet.el @@ -1,4 +1,4 @@ -;;; telnet.el --- run a telnet session from within an Emacs buffer +;;; telnet.el --- run a telnet session from within an Emacs buffer -*- lexical-binding: t; -*- ;; Copyright (C) 1985, 1988, 1992, 1994, 2001-2021 Free Software ;; Foundation, Inc. @@ -63,11 +63,11 @@ LOGIN-NAME, which is optional, says what to log in as on that machine.") (defvar telnet-new-line "\r") (defvar telnet-mode-map (let ((map (nconc (make-sparse-keymap) comint-mode-map))) - (define-key map "\C-m" 'telnet-send-input) - ;; (define-key map "\C-j" 'telnet-send-input) - (define-key map "\C-c\C-q" 'send-process-next-char) - (define-key map "\C-c\C-c" 'telnet-interrupt-subjob) - (define-key map "\C-c\C-z" 'telnet-c-z) + (define-key map "\C-m" #'telnet-send-input) + ;; (define-key map "\C-j" #'telnet-send-input) + (define-key map "\C-c\C-q" #'send-process-next-char) + (define-key map "\C-c\C-c" #'telnet-interrupt-subjob) + (define-key map "\C-c\C-z" #'telnet-c-z) map)) (defvar telnet-prompt-pattern "^[^#$%>\n]*[#$%>] *") @@ -152,7 +152,7 @@ rejecting one login and prompting again for a username and password.") (t (telnet-check-software-type-initialize string) (telnet-filter proc string) (cond ((> telnet-count telnet-maximum-count) - (set-process-filter proc 'telnet-filter)) + (set-process-filter proc #'telnet-filter)) (t (setq telnet-count (1+ telnet-count))))))))) ;; Identical to comint-simple-send, except that it sends telnet-new-line @@ -227,9 +227,9 @@ Normally input is edited in Emacs and sent a line at a time." (if (and buffer (get-buffer-process buffer)) (switch-to-buffer (concat "*" name "*")) (switch-to-buffer - (apply 'make-comint name telnet-program nil telnet-options)) + (apply #'make-comint name telnet-program nil telnet-options)) (setq process (get-buffer-process (current-buffer))) - (set-process-filter process 'telnet-initial-filter) + (set-process-filter process #'telnet-initial-filter) ;; Don't send the `open' cmd till telnet is ready for it. (accept-process-output process) (erase-buffer) @@ -263,7 +263,7 @@ Normally input is edited in Emacs and sent a line at a time." (require 'shell) (let ((name (concat "rsh-" host ))) (switch-to-buffer (make-comint name remote-shell-program nil host)) - (set-process-filter (get-process name) 'telnet-initial-filter) + (set-process-filter (get-process name) #'telnet-initial-filter) (telnet-mode) (setq-local telnet-connect-command (list 'rsh host)) (setq telnet-count -16))) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 2aacf266f2b..1e48f8dbb8c 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -250,7 +250,7 @@ function returns nil" (host (or (file-remote-p string 'host) "")) item result) (while (setq item (pop tdra)) - (when (string-match-p (or (eval (car item)) "") string) + (when (string-match-p (or (eval (car item) t) "") string) (setq tdra nil result (format-spec diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 27461e6917c..b67de1bd21b 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -70,7 +70,7 @@ It is the default value of `temporary-file-directory'." ;; We must return a local directory. If it is remote, we could run ;; into an infloop. - (eval (car (get 'temporary-file-directory 'standard-value)))) + (eval (car (get 'temporary-file-directory 'standard-value)) t)) (defsubst tramp-compat-make-temp-name () "Generate a local temporary file name (compat function)." diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index 64b5b48e7d4..5adc4ce354a 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -231,7 +231,7 @@ NAME must be equal to `tramp-current-connection'." (delete (info-lookup->mode-cache 'symbol 'tramp-info-lookup-mode) (info-lookup->topic-cache 'symbol))))) - (dolist (mode (mapcar 'car (info-lookup->topic-value 'symbol))) + (dolist (mode (mapcar #'car (info-lookup->topic-value 'symbol))) ;; Add `tramp-info-lookup-mode' to `other-modes' for either ;; `emacs-lisp-mode' itself, or to modes which use ;; `emacs-lisp-mode' as `other-modes'. Reset `info-lookup-cache'. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index dac83b82a82..7f6ecc6c327 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -4918,7 +4918,7 @@ If there is just some editing, retry it after 5 seconds." (progn (tramp-message vec 5 "Cannot timeout session, trying it again in %s seconds." 5) - (run-at-time 5 nil 'tramp-timeout-session vec)) + (run-at-time 5 nil #'tramp-timeout-session vec)) (tramp-message vec 3 "Timeout session %s" (tramp-make-tramp-file-name vec 'noloc)) (tramp-cleanup-connection vec 'keep-debug nil 'keep-processes))) @@ -5149,7 +5149,7 @@ connection if a previous connection has died for some reason." (when (tramp-get-connection-property p "session-timeout" nil) (run-at-time (tramp-get-connection-property p "session-timeout" nil) nil - 'tramp-timeout-session vec)) + #'tramp-timeout-session vec)) ;; Make initial shell settings. (tramp-open-connection-setup-interactive-shell p vec) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 47d62f38045..9f65608f3a4 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -386,6 +386,8 @@ Also see `tramp-default-method-alist'." :type 'string) (defcustom tramp-default-method-alist nil + ;; FIXME: This is not an "alist", because its elements are not of + ;; the form (KEY . VAL) but (KEY1 KEY2 VAL). "Default method to use for specific host/user pairs. This is an alist of items (HOST USER METHOD). The first matching item specifies the method to use for a file name which does not specify a @@ -413,6 +415,8 @@ This variable is regarded as obsolete, and will be removed soon." :type '(choice (const nil) string)) (defcustom tramp-default-user-alist nil + ;; FIXME: This is not an "alist", because its elements are not of + ;; the form (KEY . VAL) but (KEY1 KEY2 VAL). "Default user to use for specific method/host pairs. This is an alist of items (METHOD HOST USER). The first matching item specifies the user to use for a file name which does not specify a @@ -432,6 +436,8 @@ Useful for su and sudo methods mostly." :type 'string) (defcustom tramp-default-host-alist nil + ;; FIXME: This is not an "alist", because its elements are not of + ;; the form (KEY . VAL) but (KEY1 KEY2 VAL). "Default host to use for specific method/user pairs. This is an alist of items (METHOD USER HOST). The first matching item specifies the host to use for a file name which does not specify a @@ -447,6 +453,8 @@ empty string for the method name." (choice :tag " Host name" string (const nil))))) (defcustom tramp-default-proxies-alist nil + ;; FIXME: This is not an "alist", because its elements are not of + ;; the form (KEY . VAL) but (KEY1 KEY2 VAL). "Route to be followed for specific host/user pairs. This is an alist of items (HOST USER PROXY). The first matching item specifies the proxy to be passed for a file name located on @@ -1710,6 +1718,10 @@ version, the function does nothing." "Used for highlighting Tramp debug buffers in `outline-mode'.") (defconst tramp-debug-font-lock-keywords + ;; FIXME: Make it a function instead of an ELisp expression, so you + ;; can evaluate it with `funcall' rather than `eval'! + ;; Also, in `font-lock-defaults' you can specify a function name for + ;; the "KEYWORDS" part, so font-lock calls it to get the actual keywords! '(list (concat "^\\(?:" tramp-debug-outline-regexp "\\).+") '(1 font-lock-warning-face t t) @@ -1738,8 +1750,11 @@ The outline level is equal to the verbosity of the Tramp message." (outline-mode)) (setq-local outline-level 'tramp-debug-outline-level) (setq-local font-lock-keywords - `(t (eval ,tramp-debug-font-lock-keywords) - ,(eval tramp-debug-font-lock-keywords))) + ;; FIXME: This `(t FOO . BAR)' representation in + ;; `font-lock-keywords' is supposed to be an + ;; internal implementation "detail". Don't abuse it here! + `(t (eval ,tramp-debug-font-lock-keywords t) + ,(eval tramp-debug-font-lock-keywords t))) ;; Do not edit the debug buffer. (use-local-map special-mode-map)) (current-buffer))) @@ -3691,15 +3706,15 @@ User is always nil." (setq choices tramp-default-proxies-alist) (while choices (setq item (pop choices) - proxy (eval (nth 2 item))) + proxy (eval (nth 2 item) t)) (when (and ;; Host. (string-match-p - (or (eval (nth 0 item)) "") + (or (eval (nth 0 item) t) "") (or (tramp-file-name-host-port (car target-alist)) "")) ;; User. (string-match-p - (or (eval (nth 1 item)) "") + (or (eval (nth 1 item) t) "") (or (tramp-file-name-user-domain (car target-alist)) ""))) (if (null proxy) ;; No more hops needed. diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el index 1fa625c3245..4baa657c0a5 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el @@ -252,7 +252,7 @@ Please submit bug reports and other feedback to the author, Neil W. Van Dyke (cond ((not expr) "") ((stringp expr) expr) ((vectorp expr) (webjump-builtin expr name)) - ((listp expr) (eval expr)) + ((listp expr) (eval expr t)) ((symbolp expr) (if (fboundp expr) (funcall expr name) -- cgit v1.2.3 From 65441a6fab7a24d2433411119191002cb366c96d Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Thu, 11 Mar 2021 17:16:50 +0100 Subject: Add remote processes to Tramp sshfs method * doc/misc/tramp.texi (FUSE setup): Method sshfs supports also remote processes. * lisp/net/tramp-cache.el (tramp-get-file-property) (tramp-set-file-property): Move setting of `tramp-cache-unload-hook' out of function. * lisp/net/tramp.el (tramp-expand-args): New defun. (tramp-handle-make-process): * lisp/net/tramp-sh.el (tramp-do-copy-or-rename-file-out-of-band) (tramp-maybe-open-connection): * lisp/net/tramp-sshfs.el (tramp-sshfs-maybe-open-connection): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-send-command): Use it. * lisp/net/tramp-sshfs.el (tramp-methods) : Adapt `tramp-mount-args'. Add `tramp-login-args', `tramp-direct-async', `tramp-remote-shell', `tramp-remote-shell-login' and `tramp-remote-shell-args'. (tramp-connection-properties): Set "direct-async-process" fir sshfs. (tramp-sshfs-file-name-handler-alist): Add `exec-path', `make-process', `process-file', `set-file-modes', `shell-command', `start-file-process', `tramp-get-remote-gid', `tramp-get-remote-uid' and `tramp-set-file-uid-gid'. (tramp-sshfs-handle-exec-path, tramp-sshfs-handle-process-file) (tramp-sshfs-handle-set-file-modes): New defuns. * test/lisp/net/tramp-tests.el (tramp-test20-file-modes) (tramp-test28-process-file, tramp-test29-start-file-process) (tramp-test30-make-process, tramp-test32-shell-command) (tramp-test32-shell-command-dont-erase-buffer) (tramp-test34-explicit-shell-file-name, tramp-test35-exec-path) (tramp-test43-asynchronous-requests): Run also for tramp-sshfs. (tramp--test-shell-file-name): New defun. (tramp-test28-process-file) (tramp-test34-explicit-shell-file-name) (tramp-test43-asynchronous-requests): Use it. (tramp-test40-special-characters-with-stat) (tramp-test40-special-characters-with-perl) (tramp-test40-special-characters-with-ls) (tramp-test41-utf8-with-stat, tramp-test41-utf8-with-perl) (tramp-test41-utf8-with-ls): Remove superfluous skip. --- doc/misc/tramp.texi | 11 ++-- lisp/net/tramp-cache.el | 22 +++++--- lisp/net/tramp-sh.el | 128 ++++++++++++++++--------------------------- lisp/net/tramp-sshfs.el | 117 +++++++++++++++++++++++++++------------ lisp/net/tramp-sudoedit.el | 22 +++----- lisp/net/tramp.el | 57 ++++++++++--------- test/lisp/net/tramp-tests.el | 68 +++++++++++------------ 7 files changed, 226 insertions(+), 199 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 5958162d937..e5e15cdaa5d 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -2648,11 +2648,14 @@ visibility of files. @subsection @option{sshfs} setup @cindex sshfs setup -The method @option{sshfs} declares only the mount arguments, passed to -the @command{sshfs} command. This is a list of list of strings, and -can be overwritten by the connection property @t{"mount-args"}, -@xref{Predefined connection information}. +The method @option{sshfs} declares the mount arguments in the variable +@code{tramp-methods}, passed to the @command{sshfs} command. This is +a list of list of strings, and can be overwritten by the connection +property @t{"mount-args"}, @xref{Predefined connection information}. +Additionally. it declares also the arguments for running remote +processes, using the @command{ssh} command. These don't need to be +changed. @node Android shell setup @section Android shell setup hints diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index c79a3a02a3d..2fcb7b11e8d 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -162,17 +162,20 @@ Return DEFAULT if not set." (tramp-message key 8 "%s %s %s; inhibit: %s; cache used: %s; cached at: %s" file property value remote-file-name-inhibit-cache cache-used cached-at) + ;; For analysis purposes, count the number of getting this file attribute. (when (>= tramp-verbose 10) (let* ((var (intern (concat "tramp-cache-get-count-" property))) (val (or (and (boundp var) (numberp (symbol-value var)) (symbol-value var)) - (progn - (add-hook 'tramp-cache-unload-hook - (lambda () (makunbound var))) - 0)))) + 0))) (set var (1+ val)))) value)) +(add-hook 'tramp-cache-unload-hook + (lambda () + (dolist (var (all-completions "tramp-cache-get-count-" obarray)) + (unintern var obarray)))) + ;;;###tramp-autoload (defun tramp-set-file-property (key file property value) "Set the PROPERTY of FILE to VALUE, in the cache context of KEY. @@ -187,17 +190,20 @@ Return VALUE." ;; We put the timestamp there. (puthash property (cons (current-time) value) hash) (tramp-message key 8 "%s %s %s" file property value) + ;; For analysis purposes, count the number of setting this file attribute. (when (>= tramp-verbose 10) (let* ((var (intern (concat "tramp-cache-set-count-" property))) (val (or (and (boundp var) (numberp (symbol-value var)) (symbol-value var)) - (progn - (add-hook 'tramp-cache-unload-hook - (lambda () (makunbound var))) - 0)))) + 0))) (set var (1+ val)))) value)) +(add-hook 'tramp-cache-unload-hook + (lambda () + (dolist (var (all-completions "tramp-cache-set-count-" obarray)) + (unintern var obarray)))) + ;;;###tramp-autoload (defun tramp-flush-file-property (key file property) "Remove PROPERTY of FILE in the cache context of KEY." diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 7f6ecc6c327..14abf55e55d 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2370,53 +2370,29 @@ The method used must be an out-of-band method." (setq listener (number-to-string (+ 50000 (random 10000)))))) ;; Compose copy command. - (setq host (or host "") - user (or user "") - port (or port "") - spec (format-spec-make - ?t (tramp-get-connection-property - (tramp-get-connection-process v) "temp-file" "")) - options (format-spec (tramp-ssh-controlmaster-options v) spec) - spec (format-spec-make - ?h host ?u user ?p port ?r listener ?c options - ?k (if keep-date " " "") + (setq options + (format-spec + (tramp-ssh-controlmaster-options v) + (format-spec-make + ?t (tramp-get-connection-property + (tramp-get-connection-process v) "temp-file" ""))) + spec (list + ?h (or host "") ?u (or user "") ?p (or port "") + ?r listener ?c options ?k (if keep-date " " "") ?n (concat "2>" (tramp-get-remote-null-device v))) copy-program (tramp-get-method-parameter v 'tramp-copy-program) copy-keep-date (tramp-get-method-parameter v 'tramp-copy-keep-date) - copy-args - (delete - ;; " " has either been a replacement of "%k" (when - ;; keep-date argument is non-nil), or a replacement - ;; for the whole keep-date sublist. - " " - (dolist - (x (tramp-get-method-parameter v 'tramp-copy-args) copy-args) - (setq copy-args - (append - copy-args - (let ((y (mapcar (lambda (z) (format-spec z spec)) x))) - (unless (member "" y) y)))))) - - copy-env - (delq - nil - (mapcar - (lambda (x) - (setq x (mapcar (lambda (y) (format-spec y spec)) x)) - (unless (member "" x) (string-join x " "))) - (tramp-get-method-parameter v 'tramp-copy-env))) - + ;; " " has either been a replacement of "%k" (when + ;; keep-date argument is non-nil), or a replacement for + ;; the whole keep-date sublist. + (delete " " (apply #'tramp-expand-args v 'tramp-copy-args spec)) + copy-env (apply #'tramp-expand-args v 'tramp-copy-env spec) remote-copy-program - (tramp-get-method-parameter v 'tramp-remote-copy-program)) - - (dolist (x (tramp-get-method-parameter v 'tramp-remote-copy-args)) - (setq remote-copy-args - (append - remote-copy-args - (let ((y (mapcar (lambda (z) (format-spec z spec)) x))) - (unless (member "" y) y))))) + (tramp-get-method-parameter v 'tramp-remote-copy-program) + remote-copy-args + (apply #'tramp-expand-args v 'tramp-remote-copy-args spec)) ;; Check for local copy program. (unless (executable-find copy-program) @@ -2462,10 +2438,11 @@ The method used must be an out-of-band method." v "process-name" (buffer-name (current-buffer))) (tramp-set-connection-property v "process-buffer" (current-buffer)) - (while copy-env + (when copy-env (tramp-message - orig-vec 6 "%s=\"%s\"" (car copy-env) (cadr copy-env)) - (setenv (pop copy-env) (pop copy-env))) + orig-vec 6 "%s=\"%s\"" + (car copy-env) (string-join (cdr copy-env) " ")) + (setenv (car copy-env) (string-join (cdr copy-env) " "))) (setq copy-args (append @@ -5049,19 +5026,17 @@ connection if a previous connection has died for some reason." (l-domain (tramp-file-name-domain hop)) (l-host (tramp-file-name-host hop)) (l-port (tramp-file-name-port hop)) - (login-program - (tramp-get-method-parameter hop 'tramp-login-program)) - (login-args - (tramp-get-method-parameter hop 'tramp-login-args)) (remote-shell (tramp-get-method-parameter hop 'tramp-remote-shell)) (extra-args (tramp-get-sh-extra-args remote-shell)) (async-args - (tramp-get-method-parameter hop 'tramp-async-args)) + (tramp-compat-flatten-tree + (tramp-get-method-parameter hop 'tramp-async-args))) (connection-timeout (tramp-get-method-parameter hop 'tramp-connection-timeout)) - (command login-program) + (command + (tramp-get-method-parameter hop 'tramp-login-program)) ;; We don't create the temporary file. In ;; fact, it is just a prefix for the ;; ControlPath option of ssh; the real @@ -5075,11 +5050,7 @@ connection if a previous connection has died for some reason." (with-tramp-connection-property (tramp-get-process vec) "temp-file" (tramp-compat-make-temp-name))) - spec r-shell) - - ;; Add arguments for asynchronous processes. - (when (and process-name async-args) - (setq login-args (append async-args login-args))) + r-shell) ;; Check, whether there is a restricted shell. (dolist (elt tramp-restricted-shell-hosts-alist) @@ -5104,31 +5075,28 @@ connection if a previous connection has died for some reason." ;; Replace `login-args' place holders. (setq - l-host (or l-host "") - l-user (or l-user "") - l-port (or l-port "") - spec (format-spec-make ?t tmpfile) - options (format-spec options spec) - spec (format-spec-make - ?h l-host ?u l-user ?p l-port ?c options - ?l (concat remote-shell " " extra-args " -i")) command - (concat - ;; We do not want to see the trailing local - ;; prompt in `start-file-process'. - (unless r-shell "exec ") - command " " - (mapconcat - (lambda (x) - (setq x (mapcar (lambda (y) (format-spec y spec)) x)) - (unless (member "" x) (string-join x " "))) - login-args " ") - ;; Local shell could be a Windows COMSPEC. It - ;; doesn't know the ";" syntax, but we must exit - ;; always for `start-file-process'. It could - ;; also be a restricted shell, which does not - ;; allow "exec". - (when r-shell " && exit || exit"))) + (mapconcat + #'identity + (append + ;; We do not want to see the trailing local + ;; prompt in `start-file-process'. + (unless r-shell '("exec")) + `(,command) + ;; Add arguments for asynchronous processes. + (when process-name async-args) + (tramp-expand-args + hop 'tramp-login-args + ?h (or l-host "") ?u (or l-user "") ?p (or l-port "") + ?c (format-spec options (format-spec-make ?t tmpfile)) + ?l (concat remote-shell " " extra-args " -i")) + ;; Local shell could be a Windows COMSPEC. It + ;; doesn't know the ";" syntax, but we must + ;; exit always for `start-file-process'. It + ;; could also be a restricted shell, which does + ;; not allow "exec". + (when r-shell '("&&" "exit" "||" "exit"))) + " ")) ;; Send the command. (tramp-message vec 3 "Sending command `%s'" command) @@ -5469,7 +5437,7 @@ Nonexistent directories are removed from spec." (progn (tramp-message vec 3 - "`getconf PATH' not successful, using default value \"%s\"." + "`getconf PATH' not successful, using default value \"%s\"." "/bin:/usr/bin") "/bin:/usr/bin")))) (own-remote-path diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index feb64b82bc7..ce9412c0bea 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -51,9 +51,19 @@ (tramp--with-startup (add-to-list 'tramp-methods `(,tramp-sshfs-method - (tramp-mount-args - (("-p" "%p") - ("-o" "idmap=user,reconnect"))))) + (tramp-mount-args (("-C") ("-p" "%p") + ("-o" "idmap=user,reconnect"))) + ;; These are for remote processes. + (tramp-login-program "ssh") + (tramp-login-args (("-q")("-l" "%u") ("-p" "%p") + ("-e" "none") ("%h") ("%l"))) + (tramp-direct-async t) + (tramp-remote-shell ,tramp-default-remote-shell) + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + + (add-to-list 'tramp-connection-properties + `(,(format "/%s:" tramp-sshfs-method) "direct-async-process" t)) (tramp-set-completion-function tramp-sshfs-method tramp-completion-function-alist-ssh)) @@ -76,7 +86,7 @@ . tramp-handle-directory-files-and-attributes) (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) -;; (exec-path . ignore) + (exec-path . tramp-sshfs-handle-exec-path) (expand-file-name . tramp-handle-expand-file-name) (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . ignore) @@ -117,22 +127,22 @@ (make-directory . tramp-fuse-handle-make-directory) (make-directory-internal . ignore) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) -;; (make-process . ignore) + (make-process . tramp-handle-make-process) (make-symbolic-link . tramp-handle-make-symbolic-link) -;; (process-file . ignore) + (process-file . tramp-sshfs-handle-process-file) (rename-file . tramp-sshfs-handle-rename-file) (set-file-acl . ignore) - (set-file-modes . ignore) + (set-file-modes . tramp-sshfs-handle-set-file-modes) (set-file-selinux-context . ignore) (set-file-times . ignore) (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) -;; (shell-command . ignore) -;; (start-file-process . ignore) + (shell-command . tramp-handle-shell-command) + (start-file-process . tramp-handle-start-file-process) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) -;; (tramp-get-remote-gid . ignore) -;; (tramp-get-remote-uid . ignore) -;; (tramp-set-file-uid-gid . ignore) + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) + (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) @@ -185,6 +195,22 @@ arguments to pass to the OPERATION." (with-parsed-tramp-file-name newname nil (tramp-flush-file-properties v localname))))) +(defun tramp-sshfs-handle-exec-path () + "Like `exec-path' for Tramp files." + (append + (with-parsed-tramp-file-name default-directory nil + (with-tramp-connection-property (tramp-get-process v) "remote-path" + (with-temp-buffer + (process-file "getconf" nil t nil "PATH") + (split-string + (progn + ;; Read the expression. + (goto-char (point-min)) + (buffer-substring (point) (point-at-eol))) + ":" 'omit)))) + ;; The equivalent to `exec-directory'. + `(,(tramp-file-local-name (expand-file-name default-directory))))) + (defun tramp-sshfs-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." ;;`file-system-info' exists since Emacs 27.1. @@ -199,6 +225,34 @@ arguments to pass to the OPERATION." (when visit (setq buffer-file-name filename)) (cons (expand-file-name filename) (cdr result)))) +(defun tramp-sshfs-handle-process-file + (program &optional infile destination display &rest args) + "Like `process-file' for Tramp files." + ;; The implementation is not complete yet. + (when (and (numberp destination) (zerop destination)) + (error "Implementation does not handle immediate return")) + + (with-parsed-tramp-file-name default-directory nil + (let ((command + (format + "cd %s && exec %s" + localname + (mapconcat #'tramp-shell-quote-argument (cons program args) " ")))) + (unwind-protect + (apply + #'tramp-call-process + v (tramp-get-method-parameter v 'tramp-login-program) + infile destination display + (tramp-expand-args + v 'tramp-login-args + ?h (or (tramp-file-name-host v) "") + ?u (or (tramp-file-name-user v) "") + ?p (or (tramp-file-name-port v) "") + ?l command)) + + (unless process-file-side-effects + (tramp-flush-directory-properties v "")))))) + (defun tramp-sshfs-handle-rename-file (filename newname &optional ok-if-already-exists) "Like `rename-file' for Tramp files." @@ -217,6 +271,13 @@ arguments to pass to the OPERATION." (with-parsed-tramp-file-name newname nil (tramp-flush-file-properties v localname)))) +(defun tramp-sshfs-handle-set-file-modes (filename mode &optional flag) + "Like `set-file-modes' for Tramp files." + (with-parsed-tramp-file-name filename nil + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (tramp-flush-file-properties v localname) + (set-file-modes (tramp-fuse-local-file-name filename) mode flag)))) + (defun tramp-sshfs-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." @@ -269,28 +330,16 @@ connection if a previous connection has died for some reason." (unless (or (tramp-fuse-mounted-p vec) - (let* ((port (or (tramp-file-name-port vec) "")) - (spec (format-spec-make ?p port)) - mount-args - (mount-args - (dolist - (x - (tramp-get-method-parameter vec 'tramp-mount-args) - mount-args) - (setq mount-args - (append - mount-args - (let ((y (mapcar - (lambda (z) (format-spec z spec)) - x))) - (unless (member "" y) y))))))) - (with-temp-buffer - (zerop - (apply - #'tramp-call-process - vec tramp-sshfs-program nil t nil - (tramp-fuse-mount-spec vec) - (tramp-fuse-mount-point vec) mount-args)))) + (with-temp-buffer + (zerop + (apply + #'tramp-call-process + vec tramp-sshfs-program nil t nil + (tramp-fuse-mount-spec vec) + (tramp-fuse-mount-point vec) + (tramp-expand-args + vec 'tramp-mount-args + ?p (or (tramp-file-name-port vec) ""))))) (tramp-error vec 'file-error "Error mounting %s" (tramp-fuse-mount-spec vec)))) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index e181365162e..66737e61da7 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -791,22 +791,16 @@ in case of error, t otherwise." (tramp-sudoedit-maybe-open-connection vec) (with-current-buffer (tramp-get-connection-buffer vec) (erase-buffer) - (let* ((login (tramp-get-method-parameter vec 'tramp-sudo-login)) - (host (or (tramp-file-name-host vec) "")) - (user (or (tramp-file-name-user vec) "")) - (spec (format-spec-make ?h host ?u user)) - (args (append - (tramp-compat-flatten-tree - (mapcar - (lambda (x) - (setq x (mapcar (lambda (y) (format-spec y spec)) x)) - (unless (member "" x) x)) - login)) - (tramp-compat-flatten-tree (delq nil args)))) - (delete-exited-processes t) + (let* ((delete-exited-processes t) (process-connection-type tramp-process-connection-type) (p (apply #'start-process - (tramp-get-connection-name vec) (current-buffer) args)) + (tramp-get-connection-name vec) (current-buffer) + (append + (tramp-expand-args + vec 'tramp-sudo-login + ?h (or (tramp-file-name-host vec) "") + ?u (or (tramp-file-name-user vec) "")) + (tramp-compat-flatten-tree args)))) ;; We suppress the messages `Waiting for prompts from remote shell'. (tramp-verbose (if (= tramp-verbose 3) 2 tramp-verbose)) ;; We do not want to save the password. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 9f65608f3a4..da779d3386f 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3765,6 +3765,22 @@ User is always nil." ;; Result. target-alist)) +(defun tramp-expand-args (vec parameter &rest spec-list) + "Expand login arguments as given by PARAMETER in `tramp-methods'. +PARAMETER is a symbol like `tramp-login-args', denoting a list of +list of strings from `tramp-methods', containing %-sequences for +substitution. SPEC-LIST is a list of char/value pairs used for +`format-spec-make'." + (let ((args (tramp-get-method-parameter vec parameter)) + (spec (apply 'format-spec-make spec-list))) + ;; Expand format spec. + (tramp-compat-flatten-tree + (mapcar + (lambda (x) + (setq x (mapcar (lambda (y) (format-spec y spec)) x)) + (unless (member "" x) x)) + args)))) + (defun tramp-direct-async-process-p (&rest args) "Whether direct async `make-process' can be called." (let ((v (tramp-dissect-file-name default-directory)) @@ -3846,14 +3862,11 @@ It does not support `:stderr'." (append `("cd" ,localname "&&" "(" "env") env `(,command ")")))) ;; Check for `tramp-sh-file-name-handler', because something - ;; is different between tramp-adb.el and tramp-sh.el. + ;; is different between tramp-sh.el, and tramp-adb.el or + ;; tramp-sshfs.el. (let* ((sh-file-name-handler-p (tramp-sh-file-name-handler-p v)) (login-program (tramp-get-method-parameter v 'tramp-login-program)) - (login-args - (tramp-get-method-parameter v 'tramp-login-args)) - (async-args - (tramp-get-method-parameter v 'tramp-async-args)) ;; We don't create the temporary file. In fact, it ;; is just a prefix for the ControlPath option of ;; ssh; the real temporary file has another name, and @@ -3871,29 +3884,23 @@ It does not support `:stderr'." (when sh-file-name-handler-p (tramp-compat-funcall 'tramp-ssh-controlmaster-options v))) - spec p) + login-args p) - ;; Replace `login-args' place holders. + ;; Replace `login-args' place holders. Split + ;; ControlMaster options. (setq - spec (format-spec-make ?t tmpfile) - options (format-spec (or options "") spec) - spec (format-spec-make - ?h (or host "") ?u (or user "") ?p (or port "") - ?c options ?l "") - ;; Add arguments for asynchronous processes. - login-args (append async-args login-args) - ;; Expand format spec. login-args - (tramp-compat-flatten-tree - (mapcar - (lambda (x) - (setq x (mapcar (lambda (y) (format-spec y spec)) x)) - (unless (member "" x) x)) - login-args)) - ;; Split ControlMaster options. - login-args - (tramp-compat-flatten-tree - (mapcar (lambda (x) (split-string x " ")) login-args)) + (append + (tramp-compat-flatten-tree + (tramp-get-method-parameter v 'tramp-async-args)) + (tramp-compat-flatten-tree + (mapcar + (lambda (x) (split-string x " ")) + (tramp-expand-args + v 'tramp-login-args + ?h (or host "") ?u (or user "") ?p (or port "") + ?c (format-spec (or options "") (format-spec-make ?t tmpfile)) + ?l "")))) p (make-process :name name :buffer buffer :command (append `(,login-program) login-args command) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index d9a8065e723..6565919c771 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -3537,7 +3537,7 @@ They might differ only in time attributes or directory size." This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (skip-unless (tramp--test-enabled)) (skip-unless - (or (tramp--test-sh-p) (tramp--test-sudoedit-p) + (or (tramp--test-sh-p) (tramp--test-sshfs-p) (tramp--test-sudoedit-p) ;; Not all tramp-gvfs.el methods support changing the file mode. (and (tramp--test-gvfs-p) @@ -4368,11 +4368,15 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (and (featurep 'tramp-test-load) (unload-feature 'tramp-test-load)) (delete-file tmp-name)))))) +(defun tramp--test-shell-file-name () + "Return default remote shell.." + (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh")) + (ert-deftest tramp-test28-process-file () "Check `process-file'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) @@ -4389,25 +4393,27 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should-not (zerop (process-file "binary-does-not-exist"))) ;; Return exit code. (should (= 42 (process-file - (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh") + (tramp--test-shell-file-name) nil nil nil "-c" "exit 42"))) ;; Return exit code in case the process is interrupted, ;; and there's no indication for a signal describing string. - (let (process-file-return-signal-string) - (should - (= (+ 128 2) - (process-file - (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh") - nil nil nil "-c" "kill -2 $$")))) + (unless (tramp--test-sshfs-p) + (let (process-file-return-signal-string) + (should + (= (+ 128 2) + (process-file + (tramp--test-shell-file-name) + nil nil nil "-c" "kill -2 $$"))))) ;; Return string in case the process is interrupted and ;; there's an indication for a signal describing string. - (let ((process-file-return-signal-string t)) - (should - (string-match-p - "Interrupt\\|Signal 2" - (process-file - (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh") - nil nil nil "-c" "kill -2 $$")))) + (unless (tramp--test-sshfs-p) + (let ((process-file-return-signal-string t)) + (should + (string-match-p + "Interrupt\\|Signal 2" + (process-file + (tramp--test-shell-file-name) + nil nil nil "-c" "kill -2 $$"))))) (with-temp-buffer (write-region "foo" nil tmp-name) @@ -4451,7 +4457,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check `start-file-process'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) @@ -4571,7 +4577,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." "Check `make-process'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) (skip-unless (not (tramp--test-crypt-p))) ;; `make-process' supports file name handlers since Emacs 27. (skip-unless (tramp--test-emacs27-p)) @@ -4799,7 +4805,7 @@ INPUT, if non-nil, is a string sent to the process." ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for ;; remote processes in Emacs. That doesn't work for tramp-adb.el. (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) - (tramp--test-sh-p))) + (tramp--test-sh-p) (tramp--test-sshfs-p))) (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) @@ -4898,7 +4904,7 @@ INPUT, if non-nil, is a string sent to the process." :tags '(:expensive-test :unstable) (skip-unless (tramp--test-enabled)) (skip-unless nil) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) (skip-unless (not (tramp--test-crypt-p))) ;; Prior Emacs 27, `shell-command-dont-erase-buffer' wasn't working properly. (skip-unless (tramp--test-emacs27-p)) @@ -5223,7 +5229,7 @@ Use direct async.") ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for ;; remote processes in Emacs. That doesn't work for tramp-adb.el. (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) - (tramp--test-sh-p))) + (tramp--test-sh-p) (tramp--test-sshfs-p))) (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 26.1. (skip-unless (and (fboundp 'connection-local-set-profile-variables) @@ -5245,8 +5251,7 @@ Use direct async.") (with-no-warnings (connection-local-set-profile-variables 'remote-sh - `((explicit-shell-file-name - . ,(if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh")) + `((explicit-shell-file-name . ,(tramp--test-shell-file-name)) (explicit-sh-args . ("-c" "echo foo")))) (connection-local-set-profiles `(:application tramp @@ -5280,7 +5285,7 @@ Use direct async.") (ert-deftest tramp-test35-exec-path () "Check `exec-path' and `executable-find'." (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 27.1. (skip-unless (fboundp 'exec-path)) @@ -6120,7 +6125,6 @@ Use the `stat' command." (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) ;; We cannot use `tramp-test-vec', because this fails during compilation. (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-stat v))) @@ -6140,7 +6144,6 @@ Use the `perl' command." (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) ;; We cannot use `tramp-test-vec', because this fails during compilation. (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-perl v))) @@ -6163,7 +6166,6 @@ Use the `ls' command." (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) (let ((tramp-connection-properties (append @@ -6249,7 +6251,6 @@ Use the `stat' command." (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) ;; We cannot use `tramp-test-vec', because this fails during compilation. (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-stat v))) @@ -6273,7 +6274,6 @@ Use the `perl' command." (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) ;; We cannot use `tramp-test-vec', because this fails during compilation. (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-perl v))) @@ -6300,7 +6300,6 @@ Use the `ls' command." (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) (let ((tramp-connection-properties (append @@ -6341,6 +6340,7 @@ Use the `ls' command." "Set \"process-name\" and \"process-buffer\" connection properties. The values are derived from PROC. Run BODY. This is needed in timer functions as well as process filters and sentinels." + ;; FIXME: For tramp-sshfs.el, `processp' does not work. (declare (indent 1) (debug (processp body))) `(let* ((v (tramp-get-connection-property ,proc "vector" nil)) (pname (tramp-get-connection-property v "process-name" nil)) @@ -6380,7 +6380,7 @@ process sentinels. They shall not disturb each other." ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for ;; remote processes in Emacs. That doesn't work for tramp-adb.el. (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) - (tramp--test-sh-p))) + (tramp--test-sh-p) (tramp--test-sshfs-p))) (skip-unless (not (tramp--test-crypt-p))) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-windows-nt-p))) @@ -6390,7 +6390,7 @@ process sentinels. They shall not disturb each other." (define-key special-event-map [sigusr1] #'tramp--test-timeout-handler) (let* (;; For the watchdog. (default-directory (expand-file-name temporary-file-directory)) - (shell-file-name (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh")) + (shell-file-name (tramp--test-shell-file-name)) ;; It doesn't work on w32 systems. (watchdog (start-process-shell-command @@ -6765,8 +6765,8 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; * Work on skipped tests. Make a comment, when it is impossible. ;; * Revisit expensive tests, once problems in `tramp-error' are solved. ;; * Fix `tramp-test06-directory-file-name' for `ftp'. -;; * Implement `tramp-test31-interrupt-process' for `adb' and for -;; direct async processes. +;; * Implement `tramp-test31-interrupt-process' for `adb', `sshfs' and +;; for direct async processes. (provide 'tramp-tests) -- cgit v1.2.3 From 695f6792f1524a446d276bf5c5e53bbb4c200909 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 13 Mar 2021 14:35:39 +0100 Subject: Remove ;;;###tramp-autoload cookie from Tramp defcustoms (Bug#47063) * lisp/net/tramp-crypt.el (tramp-crypt-enabled-p): New defun. (tramp-crypt-add-directory, tramp-crypt-remove-directory): Add property `completion-predicate'. * lisp/net/tramp-sh.el (tramp-terminal-type, tramp-remote-path) (tramp-remote-process-environment): Remove. Move them to ... * lisp/net/tramp.el: ... here. --- lisp/net/tramp-adb.el | 2 -- lisp/net/tramp-cmds.el | 2 -- lisp/net/tramp-crypt.el | 19 ++++++++++++ lisp/net/tramp-gvfs.el | 1 - lisp/net/tramp-rclone.el | 1 - lisp/net/tramp-sh.el | 77 ------------------------------------------------ lisp/net/tramp-smb.el | 7 ----- lisp/net/tramp-sshfs.el | 1 - lisp/net/tramp.el | 69 +++++++++++++++++++++++++++++++++++++++++++ 9 files changed, 88 insertions(+), 91 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 6ec4d1fed38..aacf83e663f 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -44,7 +44,6 @@ :version "24.4" :type 'string) -;;;###tramp-autoload (defcustom tramp-adb-connect-if-not-connected nil "Try to run `adb connect' if provided device is not connected currently. It is used for TCP/IP devices." @@ -56,7 +55,6 @@ It is used for TCP/IP devices." (defconst tramp-adb-method "adb" "When this method name is used, forward all calls to Android Debug Bridge.") -;;;###tramp-autoload (defcustom tramp-adb-prompt "^[^#$\n\r]*[#$][[:space:]]" "Regexp used as prompt in almquist shell." :type 'regexp diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 1e48f8dbb8c..d208f0e044a 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -208,7 +208,6 @@ This includes password cache, file cache, connection cache, buffers." (dolist (name (tramp-list-remote-buffers)) (when (bufferp (get-buffer name)) (kill-buffer name)))) -;;;###tramp-autoload (defcustom tramp-default-rename-alist nil "Default target for renaming remote buffer file names. This is an alist of cons cells (SOURCE . TARGET). The first @@ -231,7 +230,6 @@ expression which always matches." :type '(repeat (cons (choice :tag "Source regexp" regexp sexp) (choice :tag "Target name" string (const nil))))) -;;;###tramp-autoload (defcustom tramp-confirm-rename-file-names t "Whether renaming a buffer file name must be confirmed." :group 'tramp diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index f8de7085e25..278fb9d8732 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -112,6 +112,14 @@ initializing a new crypted remote directory." "Non-nil when encryption support is available.") (setq tramp-crypt-enabled (executable-find tramp-crypt-encfs-program)) +;; This function takes action since Emacs 28.1, when +;; `read-extended-command-predicate' is set to +;; `command-completion-default-include-p'. +(defun tramp-crypt-enabled-p (_symbol _buffer) + "A predicate for Tramp interactive commands. +They are completed by \"M-x TAB\" only when encryption support is enabled." + tramp-crypt-enabled) + ;;;###tramp-autoload (defconst tramp-crypt-encfs-config ".encfs6.xml" "Encfs configuration file name.") @@ -469,6 +477,7 @@ See `tramp-crypt-do-encrypt-or-decrypt-file'." Files in that directory and all subdirectories will be encrypted before copying to, and decrypted after copying from that directory. File names will be also encrypted." + ;; (declare (completion tramp-crypt-enabled-p)) (interactive "DRemote directory name: ") (unless tramp-crypt-enabled (tramp-user-error nil "Feature is not enabled.")) @@ -481,10 +490,16 @@ directory. File names will be also encrypted." (setq tramp-crypt-directories (cons name tramp-crypt-directories))) (tramp-register-file-name-handlers)) +;; Starting with Emacs 28.1, this can be replaced by the "(declare ...)" form. +;;;###tramp-autoload +(function-put + #'tramp-crypt-add-directory 'completion-predicate #'tramp-crypt-enabled-p) + (defun tramp-crypt-remove-directory (name) "Unmark remote directory NAME for encryption. Existing files in that directory and its subdirectories will be kept in their encrypted form." + ;; (declare (completion tramp-crypt-enabled-p)) (interactive "DRemote directory name: ") (unless tramp-crypt-enabled (tramp-user-error nil "Feature is not enabled.")) @@ -498,6 +513,10 @@ kept in their encrypted form." (setq tramp-crypt-directories (delete name tramp-crypt-directories)) (tramp-register-file-name-handlers))) +;; Starting with Emacs 28.1, this can be replaced by the "(declare ...)" form. +(function-put + #'tramp-crypt-remove-directory 'completion-predicate #'tramp-crypt-enabled-p) + ;; `auth-source' requires a user. (defun tramp-crypt-dissect-file-name (name) "Return a `tramp-file-name' structure for NAME. diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 9d4e04ca689..c4ec1121da2 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -175,7 +175,6 @@ They are checked during start up via (dbus-list-known-names :session)) (setq tramp-media-methods (delete method tramp-media-methods))))) -;;;###tramp-autoload (defcustom tramp-gvfs-zeroconf-domain "local" "Zeroconf domain to be used for discovering services, like host names." :group 'tramp diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index e6f9fe56ec0..3b6de3e0b70 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -42,7 +42,6 @@ (defconst tramp-rclone-method "rclone" "When this method name is used, forward all calls to rclone mounts.") -;;;###tramp-autoload (defcustom tramp-rclone-program "rclone" "Name of the rclone program." :group 'tramp diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 14abf55e55d..7182cd6b1d9 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -46,7 +46,6 @@ (defconst tramp-default-remote-shell "/bin/sh" "The default remote shell Tramp applies.") -;;;###tramp-autoload (defcustom tramp-inline-compress-start-size 4096 "The minimum size of compressing where inline transfer. When inline transfer, compress transferred data of file whose @@ -56,23 +55,12 @@ If it is nil, no compression at all will be applied." :group 'tramp :type '(choice (const nil) integer)) -;;;###tramp-autoload (defcustom tramp-copy-size-limit 10240 "Maximum file size where inline copying is preferred to an out-of-the-band copy. If it is nil, out-of-the-band copy will be used without a check." :group 'tramp :type '(choice (const nil) integer)) -;;;###tramp-autoload -(defcustom tramp-terminal-type "dumb" - "Value of TERM environment variable for logging in to remote host. -Because Tramp wants to parse the output of the remote shell, it is easily -confused by ANSI color escape sequences and suchlike. Often, shell init -files conditionalize this setup based on the TERM environment variable." - :group 'tramp - :type 'string) - -;;;###tramp-autoload (defcustom tramp-histfile-override "~/.tramp_history" "When invoking a shell, override the HISTFILE with this value. When setting to a string, it redirects the shell history to that @@ -115,7 +103,6 @@ detected as prompt when being sent on echoing hosts, therefore.") (defconst tramp-end-of-heredoc (md5 tramp-end-of-output) "String used to recognize end of heredoc strings.") -;;;###tramp-autoload (defcustom tramp-use-ssh-controlmaster-options t "Whether to use `tramp-ssh-controlmaster-options'. Set it to nil, if you use Control* or Proxy* options in your ssh @@ -477,70 +464,6 @@ The string is used in `tramp-methods'.") (tramp-set-completion-function "psftp" tramp-completion-function-alist-ssh) (tramp-set-completion-function "fcp" tramp-completion-function-alist-ssh)) -;; "getconf PATH" yields: -;; HP-UX: /usr/bin:/usr/ccs/bin:/opt/ansic/bin:/opt/langtools/bin:/opt/fortran/bin -;; Solaris: /usr/xpg4/bin:/usr/ccs/bin:/usr/bin:/opt/SUNWspro/bin -;; GNU/Linux (Debian, Suse, RHEL): /bin:/usr/bin -;; FreeBSD, DragonFly: /usr/bin:/bin:/usr/sbin:/sbin: - beware trailing ":"! -;; FreeBSD 12.1, Darwin: /usr/bin:/bin:/usr/sbin:/sbin -;; IRIX64: /usr/bin -;; QNAP QTS: --- -;; Hydra: /run/current-system/sw/bin:/bin:/usr/bin -;;;###tramp-autoload -(defcustom tramp-remote-path - '(tramp-default-remote-path "/bin" "/usr/bin" "/sbin" "/usr/sbin" - "/usr/local/bin" "/usr/local/sbin" "/local/bin" "/local/freeware/bin" - "/local/gnu/bin" "/usr/freeware/bin" "/usr/pkg/bin" "/usr/contrib/bin" - "/opt/bin" "/opt/sbin" "/opt/local/bin") - "List of directories to search for executables on remote host. -For every remote host, this variable will be set buffer local, -keeping the list of existing directories on that host. - -You can use \"~\" in this list, but when searching for a shell which groks -tilde expansion, all directory names starting with \"~\" will be ignored. - -`Default Directories' represent the list of directories given by -the command \"getconf PATH\". It is recommended to use this -entry on head of this list, because these are the default -directories for POSIX compatible commands. On remote hosts which -do not offer the getconf command (like cygwin), the value -\"/bin:/usr/bin\" is used instead. This entry is represented in -the list by the special value `tramp-default-remote-path'. - -`Private Directories' are the settings of the $PATH environment, -as given in your `~/.profile'. This entry is represented in -the list by the special value `tramp-own-remote-path'." - :group 'tramp - :type '(repeat (choice - (const :tag "Default Directories" tramp-default-remote-path) - (const :tag "Private Directories" tramp-own-remote-path) - (string :tag "Directory")))) - -;;;###tramp-autoload -(defcustom tramp-remote-process-environment - '("ENV=''" "TMOUT=0" "LC_CTYPE=''" - "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH=" "PAGER=cat" - "autocorrect=" "correct=") - "List of environment variables to be set on the remote host. - -Each element should be a string of the form ENVVARNAME=VALUE. An -entry ENVVARNAME= disables the corresponding environment variable, -which might have been set in the init files like ~/.profile. - -Special handling is applied to some environment variables, -which should not be set here: - -The PATH environment variable should be set via `tramp-remote-path'. - -The TERM environment variable should be set via `tramp-terminal-type'. - -The INSIDE_EMACS environment variable will automatically be set -based on the Tramp and Emacs versions, and should not be set here." - :group 'tramp - :version "26.1" - :type '(repeat string)) - -;;;###tramp-autoload (defcustom tramp-sh-extra-args '(("/bash\\'" . "-noediting -norc -noprofile") ("/zsh\\'" . "-f +Z -V")) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 69359553e44..6fbf08801e8 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -60,20 +60,17 @@ tramp-smb-method '((tramp-parse-netrc "~/.netrc")))) -;;;###tramp-autoload (defcustom tramp-smb-program "smbclient" "Name of SMB client to run." :group 'tramp :type 'string) -;;;###tramp-autoload (defcustom tramp-smb-acl-program "smbcacls" "Name of SMB acls to run." :group 'tramp :type 'string :version "24.4") -;;;###tramp-autoload (defcustom tramp-smb-conf null-device "Path of the \"smb.conf\" file. If it is nil, no \"smb.conf\" will be added to the `tramp-smb-program' @@ -81,7 +78,6 @@ call, letting the SMB client use the default one." :group 'tramp :type '(choice (const nil) (file :must-match t))) -;;;###tramp-autoload (defcustom tramp-smb-options nil "List of additional options. They are added to the `tramp-smb-program' call via \"--option '...'\". @@ -305,7 +301,6 @@ See `tramp-actions-before-shell' for more info.") Operations not mentioned here will be handled by the default Emacs primitives.") ;; Options for remote processes via winexe. -;;;###tramp-autoload (defcustom tramp-smb-winexe-program "winexe" "Name of winexe client to run. If it isn't found in the local $PATH, the absolute path of winexe @@ -314,7 +309,6 @@ shall be given. This is needed for remote processes." :type 'string :version "24.3") -;;;###tramp-autoload (defcustom tramp-smb-winexe-shell-command "powershell.exe" "Shell to be used for processes on remote machines. This must be Powershell V2 compatible." @@ -322,7 +316,6 @@ This must be Powershell V2 compatible." :type 'string :version "24.3") -;;;###tramp-autoload (defcustom tramp-smb-winexe-shell-command-switch "-file -" "Command switch used together with `tramp-smb-winexe-shell-command'. This can be used to disable echo etc." diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 2a00d5ce678..c4a36fe2a3a 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -40,7 +40,6 @@ (defconst tramp-sshfs-method "sshfs" "Tramp method for sshfs mounts.") -;;;###tramp-autoload (defcustom tramp-sshfs-program "sshfs" "The sshfs mount command." :group 'tramp diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index da779d3386f..8141f026f74 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -660,6 +660,14 @@ The regexp should match at end of buffer. See also `tramp-yesno-prompt-regexp'." :type 'regexp) +(defcustom tramp-terminal-type "dumb" + "Value of TERM environment variable for logging in to remote host. +Because Tramp wants to parse the output of the remote shell, it is easily +confused by ANSI color escape sequences and suchlike. Often, shell init +files conditionalize this setup based on the TERM environment variable." + :group 'tramp + :type 'string) + (defcustom tramp-terminal-prompt-regexp (concat "\\(" "TERM = (.*)" @@ -1243,6 +1251,67 @@ let-bind this variable." :version "24.4" :type '(choice (const nil) integer)) +;; "getconf PATH" yields: +;; HP-UX: /usr/bin:/usr/ccs/bin:/opt/ansic/bin:/opt/langtools/bin:/opt/fortran/bin +;; Solaris: /usr/xpg4/bin:/usr/ccs/bin:/usr/bin:/opt/SUNWspro/bin +;; GNU/Linux (Debian, Suse, RHEL): /bin:/usr/bin +;; FreeBSD, DragonFly: /usr/bin:/bin:/usr/sbin:/sbin: - beware trailing ":"! +;; FreeBSD 12.1, Darwin: /usr/bin:/bin:/usr/sbin:/sbin +;; IRIX64: /usr/bin +;; QNAP QTS: --- +;; Hydra: /run/current-system/sw/bin:/bin:/usr/bin +(defcustom tramp-remote-path + '(tramp-default-remote-path "/bin" "/usr/bin" "/sbin" "/usr/sbin" + "/usr/local/bin" "/usr/local/sbin" "/local/bin" "/local/freeware/bin" + "/local/gnu/bin" "/usr/freeware/bin" "/usr/pkg/bin" "/usr/contrib/bin" + "/opt/bin" "/opt/sbin" "/opt/local/bin") + "List of directories to search for executables on remote host. +For every remote host, this variable will be set buffer local, +keeping the list of existing directories on that host. + +You can use \"~\" in this list, but when searching for a shell which groks +tilde expansion, all directory names starting with \"~\" will be ignored. + +`Default Directories' represent the list of directories given by +the command \"getconf PATH\". It is recommended to use this +entry on head of this list, because these are the default +directories for POSIX compatible commands. On remote hosts which +do not offer the getconf command (like cygwin), the value +\"/bin:/usr/bin\" is used instead. This entry is represented in +the list by the special value `tramp-default-remote-path'. + +`Private Directories' are the settings of the $PATH environment, +as given in your `~/.profile'. This entry is represented in +the list by the special value `tramp-own-remote-path'." + :group 'tramp + :type '(repeat (choice + (const :tag "Default Directories" tramp-default-remote-path) + (const :tag "Private Directories" tramp-own-remote-path) + (string :tag "Directory")))) + +(defcustom tramp-remote-process-environment + '("ENV=''" "TMOUT=0" "LC_CTYPE=''" + "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH=" "PAGER=cat" + "autocorrect=" "correct=") + "List of environment variables to be set on the remote host. + +Each element should be a string of the form ENVVARNAME=VALUE. An +entry ENVVARNAME= disables the corresponding environment variable, +which might have been set in the init files like ~/.profile. + +Special handling is applied to some environment variables, +which should not be set here: + +The PATH environment variable should be set via `tramp-remote-path'. + +The TERM environment variable should be set via `tramp-terminal-type'. + +The INSIDE_EMACS environment variable will automatically be set +based on the Tramp and Emacs versions, and should not be set here." + :group 'tramp + :version "26.1" + :type '(repeat string)) + (defcustom tramp-completion-reread-directory-timeout 10 "Defines seconds since last remote command before rereading a directory. A remote directory might have changed its contents. In order to -- cgit v1.2.3 From 52a74604160387230c104e3305a5e08fa8c3fdf6 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Thu, 25 Mar 2021 12:02:57 +0100 Subject: Adapt Tramp file notification support * lisp/net/tramp-integration.el (tramp-use-ssh-controlmaster-options): Declare it. * lisp/net/tramp-sh.el (tramp-sh-handle-file-notify-add-watch): Remove "gvfs-monitor-dir". (tramp-sh-gvfs-monitor-dir-process-filter) (tramp-get-remote-gvfs-monitor-dir): Remove. (tramp-get-remote-gio-file-monitor): Support also cygwin, and GFamDirectoryMonitor, GPollFileMonitor. --- lisp/net/tramp-integration.el | 1 + lisp/net/tramp-sh.el | 81 +++---------------------------------------- 2 files changed, 5 insertions(+), 77 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index 9d4dd7d42a5..2931b4f0cc8 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -49,6 +49,7 @@ (defvar recentf-exclude) (defvar tramp-current-connection) (defvar tramp-postfix-host-format) +(defvar tramp-use-ssh-controlmaster-options) ;;; Fontification of `read-file-name': diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 7182cd6b1d9..d6fdbb0419f 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -3686,18 +3686,6 @@ Fall back to normal file name handler if no Tramp handler exists." '(created changed changes-done-hint moved deleted)) ((memq 'attribute-change flags) '(attribute-changed))) sequence `(,command "monitor" ,localname))) - ;; "gvfs-monitor-dir". - ((setq command (tramp-get-remote-gvfs-monitor-dir v)) - (setq filter #'tramp-sh-gvfs-monitor-dir-process-filter - events - (cond - ((and (memq 'change flags) (memq 'attribute-change flags)) - '(created changed changes-done-hint moved deleted - attribute-changed)) - ((memq 'change flags) - '(created changed changes-done-hint moved deleted)) - ((memq 'attribute-change flags) '(attribute-changed))) - sequence `(,command ,localname))) ;; None. (t (tramp-error v 'file-notify-error @@ -3795,56 +3783,6 @@ Fall back to normal file name handler if no Tramp handler exists." (when string (tramp-message proc 10 "Rest string:\n%s" string)) (process-put proc 'rest-string string))) -(defun tramp-sh-gvfs-monitor-dir-process-filter (proc string) - "Read output from \"gvfs-monitor-dir\" and add corresponding \ -`file-notify' events." - (let ((events (process-get proc 'events)) - (remote-prefix - (with-current-buffer (process-buffer proc) - (file-remote-p default-directory))) - (rest-string (process-get proc 'rest-string))) - (when rest-string - (tramp-message proc 10 "Previous string:\n%s" rest-string)) - (tramp-message proc 6 "%S\n%s" proc string) - (setq string (concat rest-string string) - ;; Attribute change is returned in unused wording. - string (tramp-compat-string-replace - "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string)) - - (while (string-match - (concat "^[\n\r]*" - "Directory Monitor Event:[\n\r]+" - "Child = \\([^\n\r]+\\)[\n\r]+" - "\\(Other = \\([^\n\r]+\\)[\n\r]+\\)?" - "Event = \\([^[:blank:]]+\\)[\n\r]+") - string) - (let* ((file (match-string 1 string)) - (file1 (match-string 3 string)) - (object - (list - proc - (list - (intern-soft - (tramp-compat-string-replace - "_" "-" (downcase (match-string 4 string))))) - ;; File names are returned as absolute paths. We must - ;; add the remote prefix. - (concat remote-prefix file) - (when file1 (concat remote-prefix file1))))) - (setq string (replace-match "" nil nil string)) - ;; Usually, we would add an Emacs event now. Unfortunately, - ;; `unread-command-events' does not accept several events at - ;; once. Therefore, we apply the handler directly. - (when (member (cl-caadr object) events) - (tramp-compat-funcall - (lookup-key special-event-map [file-notify]) - `(file-notify ,object file-notify-callback))))) - - ;; Save rest of the string. - (when (zerop (length string)) (setq string nil)) - (when string (tramp-message proc 10 "Rest string:\n%s" string)) - (process-put proc 'rest-string string))) - (defun tramp-sh-inotifywait-process-filter (proc string) "Read output from \"inotifywait\" and add corresponding `file-notify' events." (let ((events (process-get proc 'events))) @@ -5658,7 +5596,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." ;; linked libraries of libgio. (when (tramp-send-command-and-check vec (concat "ldd " gio)) (goto-char (point-min)) - (when (re-search-forward "\\S-+/libgio\\S-+") + (when (re-search-forward "\\S-+/\\(libgio\\|cyggio\\)\\S-+") (when (tramp-send-command-and-check vec (concat "strings " (match-string 0))) (goto-char (point-min)) @@ -5666,23 +5604,12 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." (format "^%s$" (regexp-opt - '("GFamFileMonitor" "GFenFileMonitor" - "GInotifyFileMonitor" "GKqueueFileMonitor"))) + '("GFamFileMonitor" "GFamDirectoryMonitor" "GFenFileMonitor" + "GInotifyFileMonitor" "GKqueueFileMonitor" + "GPollFileMonitor"))) nil 'noerror) (intern (match-string 0))))))))) -(defun tramp-get-remote-gvfs-monitor-dir (vec) - "Determine remote `gvfs-monitor-dir' command." - (with-tramp-connection-property vec "gvfs-monitor-dir" - (tramp-message vec 5 "Finding a suitable `gvfs-monitor-dir' command") - ;; We distinguish "gvfs-monitor-dir.exe" from cygwin in order to - ;; establish better timeouts in filenotify-tests.el. Any better - ;; distinction approach would be welcome! - (or (tramp-find-executable - vec "gvfs-monitor-dir.exe" (tramp-get-remote-path vec) t t) - (tramp-find-executable - vec "gvfs-monitor-dir" (tramp-get-remote-path vec) t t)))) - (defun tramp-get-remote-inotifywait (vec) "Determine remote `inotifywait' command." (with-tramp-connection-property vec "inotifywait" -- cgit v1.2.3 From c2e72610d217f52d868c62102ff25e3279510e47 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Fri, 26 Mar 2021 19:30:05 +0100 Subject: Improve remote file notifications * lisp/net/tramp-sh.el (tramp-get-remote-gio-file-monitor): Remove it. (tramp-sh-handle-file-notify-add-watch): Do not call it. (tramp-sh-gio-monitor-process-filter): Read monitor name. * test/lisp/filenotify-tests.el (file-notify--test-read-event) (file-notify--test-timeout): Change timings. (file-notify--test-monitor): Read remote monitor name more reliably. (file-notify-test02-rm-watch): Retrieve remote monitor name in time. (file-notify--test-event-actions): New defun. (file-notify--test-with-actions-explainer): Use it. (file-notify--test-with-actions-check): Use it. Dump traces in case of debug. (file-notify--test-with-actions): Don't stop while debugging. (file-notify-test03-events, file-notify-test04-autorevert) (file-notify-test05-file-validity) (file-notify-test07-many-events, file-notify-test08-backup) (file-notify-test09-watched-file-in-watched-dir): Adapt tests. --- lisp/net/tramp-sh.el | 124 ++++++++++----------- test/lisp/filenotify-tests.el | 247 +++++++++++++++++++++++------------------- 2 files changed, 197 insertions(+), 174 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index d6fdbb0419f..1764f2ef03f 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -3654,6 +3654,8 @@ Fall back to normal file name handler if no Tramp handler exists." (setq file-name (expand-file-name file-name)) (with-parsed-tramp-file-name file-name nil (let ((default-directory (file-name-directory file-name)) + (process-environment + (cons "GIO_USE_FILE_MONITOR=help" process-environment)) command events filter p sequence) (cond ;; "inotifywait". @@ -3718,10 +3720,6 @@ Fall back to normal file name handler if no Tramp handler exists." (unless (process-live-p p) (tramp-error p 'file-notify-error "Monitoring not supported for `%s'" file-name)) - ;; Set "gio-file-monitor" property if needed. - (when (string-equal (file-name-nondirectory command) "gio") - (tramp-set-connection-property - p "gio-file-monitor" (tramp-get-remote-gio-file-monitor v))) p)))) (defun tramp-sh-gio-monitor-process-filter (proc string) @@ -3742,41 +3740,64 @@ Fall back to normal file name handler if no Tramp handler exists." "changes done" "changes-done-hint" string) string (tramp-compat-string-replace "renamed to" "moved" string)) - ;; https://bugs.launchpad.net/bugs/1742946 - (when - (string-match-p "Monitoring not supported\\|No locations given" string) - (delete-process proc)) - - ;; Delete empty lines. - (setq string (tramp-compat-string-replace "\n\n" "\n" string)) - - (while (string-match - (eval-when-compile - (concat "^[^:]+:" - "[[:space:]]\\([^:]+\\):" - "[[:space:]]" (regexp-opt tramp-gio-events t) - "\\([[:space:]]\\([^:]+\\)\\)?$")) - string) - - (let* ((file (match-string 1 string)) - (file1 (match-string 4 string)) - (object - (list - proc - (list - (intern-soft (match-string 2 string))) - ;; File names are returned as absolute paths. We must - ;; add the remote prefix. - (concat remote-prefix file) - (when file1 (concat remote-prefix file1))))) - (setq string (replace-match "" nil nil string)) - ;; Usually, we would add an Emacs event now. Unfortunately, - ;; `unread-command-events' does not accept several events at - ;; once. Therefore, we apply the handler directly. - (when (member (cl-caadr object) events) - (tramp-compat-funcall - (lookup-key special-event-map [file-notify]) - `(file-notify ,object file-notify-callback))))) + + (catch 'doesnt-work + ;; https://bugs.launchpad.net/bugs/1742946 + (when + (string-match-p "Monitoring not supported\\|No locations given" string) + (delete-process proc) + (throw 'doesnt-work nil)) + + ;; Determine monitor name. + (unless (tramp-connection-property-p proc "gio-file-monitor") + (cond + ;; We have seen this only on cygwin gio, which uses the + ;; GPollFileMonitor. + ((string-match + "Can't find module 'help' specified in GIO_USE_FILE_MONITOR" string) + (tramp-set-connection-property + proc "gio-file-monitor" 'GPollFileMonitor)) + ;; TODO: What happens, if several monitor names are reported? + ((string-match "\ +Supported arguments for GIO_USE_FILE_MONITOR environment variable: +\\s-*\\([[:alpha:]]+\\) - 20" string) + (tramp-set-connection-property + proc "gio-file-monitor" + (intern + (format "G%sFileMonitor" (capitalize (match-string 1 string)))))) + (t (throw 'doesnt-work nil))) + (setq string (replace-match "" nil nil string))) + + ;; Delete empty lines. + (setq string (tramp-compat-string-replace "\n\n" "\n" string)) + + (while (string-match + (eval-when-compile + (concat "^[^:]+:" + "[[:space:]]\\([^:]+\\):" + "[[:space:]]" (regexp-opt tramp-gio-events t) + "\\([[:space:]]\\([^:]+\\)\\)?$")) + string) + + (let* ((file (match-string 1 string)) + (file1 (match-string 4 string)) + (object + (list + proc + (list + (intern-soft (match-string 2 string))) + ;; File names are returned as absolute paths. We + ;; must add the remote prefix. + (concat remote-prefix file) + (when file1 (concat remote-prefix file1))))) + (setq string (replace-match "" nil nil string)) + ;; Usually, we would add an Emacs event now. Unfortunately, + ;; `unread-command-events' does not accept several events at + ;; once. Therefore, we apply the handler directly. + (when (member (cl-caadr object) events) + (tramp-compat-funcall + (lookup-key special-event-map [file-notify]) + `(file-notify ,object file-notify-callback)))))) ;; Save rest of the string. (when (zerop (length string)) (setq string nil)) @@ -5585,31 +5606,6 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." (tramp-message vec 5 "Finding a suitable `gio-monitor' command") (tramp-find-executable vec "gio" (tramp-get-remote-path vec) t t))) -(defun tramp-get-remote-gio-file-monitor (vec) - "Determine remote GFileMonitor." - (with-tramp-connection-property vec "gio-file-monitor" - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 5 "Finding the used GFileMonitor") - (when-let ((gio (tramp-get-remote-gio-monitor vec))) - ;; Search for the used FileMonitor. There is no known way to - ;; get this information directly from gio, so we check for - ;; linked libraries of libgio. - (when (tramp-send-command-and-check vec (concat "ldd " gio)) - (goto-char (point-min)) - (when (re-search-forward "\\S-+/\\(libgio\\|cyggio\\)\\S-+") - (when (tramp-send-command-and-check - vec (concat "strings " (match-string 0))) - (goto-char (point-min)) - (re-search-forward - (format - "^%s$" - (regexp-opt - '("GFamFileMonitor" "GFamDirectoryMonitor" "GFenFileMonitor" - "GInotifyFileMonitor" "GKqueueFileMonitor" - "GPollFileMonitor"))) - nil 'noerror) - (intern (match-string 0))))))))) - (defun tramp-get-remote-inotifywait (vec) "Determine remote `inotifywait' command." (with-tramp-connection-property vec "inotifywait" diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index d73b072661a..4a2f1f9a676 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -107,19 +107,19 @@ There are different timeouts for local and remote file notification libraries." (cond ;; gio/gpollfilemonitor.c declares POLL_TIME_SECS 5. So we must ;; wait at least this time in the GPollFileMonitor case. A - ;; similar timeout seems to be needed in the GFamFileMonitor case, - ;; at least on cygwin. - ((memq (file-notify--test-monitor) '(GFamFileMonitor GPollFileMonitor)) 7) - ((string-equal (file-notify--test-library) "gvfs-monitor-dir.exe") 1) + ;; similar timeout seems to be needed in the + ;; GFam{File,Directory}Monitor case. So we use a large timeout + ;; for any monitor. + ((file-notify--test-monitor) 7) ((file-remote-p temporary-file-directory) 0.1) (t 0.01)))) (defun file-notify--test-timeout () "Timeout to wait for arriving a bunch of events, in seconds." (cond + ((eq system-type 'cygwin) 10) ((file-remote-p temporary-file-directory) 6) ((string-equal (file-notify--test-library) "w32notify") 4) - ((eq system-type 'cygwin) 6) (t 3))) (defmacro file-notify--test-wait-for-events (timeout until) @@ -256,24 +256,37 @@ remote host, or nil." (defun file-notify--test-monitor () "The used monitor for the test, as a symbol. -This returns only for the local case and gfilenotify; otherwise it is nil. -`file-notify--test-desc' must be a valid watch descriptor." +This returns only for (local) gfilenotify or (remote) gio library; +otherwise it is nil. `file-notify--test-desc' must be a valid +watch descriptor." ;; We cache the result, because after `file-notify-rm-watch', ;; `gfile-monitor-name' does not return a proper result anymore. - ;; But we still need this information. - ;; So far, we know the monitors GFamFileMonitor, GFenFileMonitor, - ;; GInotifyFileMonitor, GKqueueFileMonitor and GPollFileMonitor. - (or (cdr (assq file-notify--test-desc file-notify--test-monitors)) - (progn - (add-to-list - 'file-notify--test-monitors - (cons file-notify--test-desc - (if (file-remote-p temporary-file-directory) - (tramp-get-connection-property - file-notify--test-desc "gio-file-monitor" nil) - (and (functionp 'gfile-monitor-name) - (gfile-monitor-name file-notify--test-desc))))) - (cdr (assq file-notify--test-desc file-notify--test-monitors))))) + ;; But we still need this information. So far, we know the monitors + ;; GFamFileMonitor (gfilenotify on cygwin), GFamDirectoryMonitor + ;; (gfilenotify on Solaris), GInotifyFileMonitor (gfilenotify and + ;; gio on GNU/Linux), GKqueueFileMonitor (gfilenotify and gio on + ;; FreeBSD) and GPollFileMonitor (gio on cygwin). + (when file-notify--test-desc + (or (alist-get file-notify--test-desc file-notify--test-monitors) + (when (member (file-notify--test-library) '("gfilenotify" "gio")) + (add-to-list + 'file-notify--test-monitors + (cons file-notify--test-desc + (if (file-remote-p temporary-file-directory) + ;; `file-notify--test-desc' is the connection process. + (progn + (while (not (tramp-connection-property-p + file-notify--test-desc "gio-file-monitor")) + (accept-process-output file-notify--test-desc 0)) + (tramp-get-connection-property + file-notify--test-desc "gio-file-monitor" nil)) + (and (functionp 'gfile-monitor-name) + (gfile-monitor-name file-notify--test-desc))))) + ;; If we don't know the monitor, there are good chances the + ;; test will fail. We let it fail already here, in order to + ;; know the real reason. + (should (alist-get file-notify--test-desc file-notify--test-monitors))) + (alist-get file-notify--test-desc file-notify--test-monitors)))) (defmacro file-notify--deftest-remote (test docstring &optional unstable) "Define ert `TEST-remote' for remote files. @@ -484,6 +497,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (file-notify-add-watch file-notify--test-tmpfile '(change) #'second-callback))) + ;; `file-notify-rm-watch' confuses `file-notify--test-monitor'. + ;; Initialize it in time. + (file-notify--test-monitor) ;; Remove first watch. (file-notify-rm-watch file-notify--test-desc) ;; Only the second callback shall run. @@ -547,6 +563,10 @@ and the event to `file-notify--test-events'." file-notify--test-results (append file-notify--test-results `(,result)))))) +(defun file-notify--test-event-actions () + "Helper function to return retrieved actions, as list." + (mapcar #'file-notify--test-event-action file-notify--test-events)) + (defun file-notify--test-with-actions-check (actions) "Check whether received actions match one of the ACTIONS alternatives." (let (result) @@ -555,22 +575,25 @@ and the event to `file-notify--test-events'." (or result (if (eq (car elt) :random) (equal (sort (cdr elt) 'string-lessp) - (sort (mapcar #'file-notify--test-event-action - file-notify--test-events) + (sort (file-notify--test-event-actions) 'string-lessp)) - (equal elt (mapcar #'file-notify--test-event-action - file-notify--test-events)))))))) + (equal elt (file-notify--test-event-actions)))))) + ;; Do not report result in case we debug. Write messages instead. + (if file-notify-debug + (prog1 t + (if result + (message "Success\n%s" (file-notify--test-event-actions)) + (message (file-notify--test-with-actions-explainer actions)))) + result))) (defun file-notify--test-with-actions-explainer (actions) "Explain why `file-notify--test-with-actions-check' fails." (if (null (cdr actions)) (format "Received actions do not match expected actions\n%s\n%s" - (mapcar #'file-notify--test-event-action file-notify--test-events) - (car actions)) + (file-notify--test-event-actions) (car actions)) (format "Received actions do not match any sequence of expected actions\n%s\n%s" - (mapcar #'file-notify--test-event-action file-notify--test-events) - actions))) + (file-notify--test-event-actions) actions))) (put 'file-notify--test-with-actions-check 'ert-explainer 'file-notify--test-with-actions-explainer) @@ -592,6 +615,9 @@ delivered." (mapcar (lambda (x) (length (if (eq (car x) :random) (cdr x) x))) actions))) + ;; Don't stop while debugging. + (while-no-input-ignore-events + (cons 'file-notify while-no-input-ignore-events)) create-lockfiles) ;; Flush pending actions. (file-notify--test-read-event) @@ -632,16 +658,11 @@ delivered." '(change) #'file-notify--test-event-handler))) (file-notify--test-with-actions (cond - ;; gvfs-monitor-dir on cygwin does not detect the - ;; `created' event reliably. - ((string-equal (file-notify--test-library) "gvfs-monitor-dir.exe") - '((deleted stopped) - (created deleted stopped))) - ;; cygwin does not raise a `changed' event. - ((eq system-type 'cygwin) - '(created deleted stopped)) - ;; GKqueueFileMonitor does not report the `changed' event. - ((equal (file-notify--test-monitor) 'GKqueueFileMonitor) + ;; GFam{File,Directory}Monitor, GKqueueFileMonitor and + ;; GPollFileMonitor do not report the `changed' event. + ((memq (file-notify--test-monitor) + '(GFamFileMonitor GFamDirectoryMonitor + GKqueueFileMonitor GPollFileMonitor)) '(created deleted stopped)) (t '(created changed deleted stopped))) (write-region @@ -668,13 +689,14 @@ delivered." '(change) #'file-notify--test-event-handler))) (file-notify--test-with-actions (cond - ;; gvfs-monitor-dir on cygwin does not detect the - ;; `changed' event reliably. - ((string-equal (file-notify--test-library) "gvfs-monitor-dir.exe") + ;; GFam{File,Directory}Monitor and GPollFileMonitor do + ;; not detect the `changed' event reliably. + ((memq (file-notify--test-monitor) + '(GFamFileMonitor GFamDirectoryMonitor GPollFileMonitor)) '((deleted stopped) (changed deleted stopped))) ;; GKqueueFileMonitor does not report the `changed' event. - ((equal (file-notify--test-monitor) 'GKqueueFileMonitor) + ((eq (file-notify--test-monitor) 'GKqueueFileMonitor) '(deleted stopped)) ;; There could be one or two `changed' events. (t '((changed deleted stopped) @@ -709,25 +731,22 @@ delivered." ;; events for the watched directory. ((string-equal (file-notify--test-library) "w32notify") '(created changed deleted)) - ;; gvfs-monitor-dir on cygwin does not detect the - ;; `created' event reliably. - ((string-equal - (file-notify--test-library) "gvfs-monitor-dir.exe") - '((deleted stopped) - (created deleted stopped))) ;; On emba, `deleted' and `stopped' events of the ;; directory are not detected. ((getenv "EMACS_EMBA_CI") '(created changed deleted)) ;; There are two `deleted' events, for the file and for - ;; the directory. Except for cygwin and kqueue. And - ;; cygwin does not raise a `changed' event. - ((eq system-type 'cygwin) + ;; the directory. Except for + ;; GFam{File,Directory}Monitor, GPollFileMonitor and + ;; kqueue. And GFam{File,Directory}Monitor and + ;; GPollFileMonitordo not raise a `changed' event. + ((memq (file-notify--test-monitor) + '(GFamFileMonitor GFamDirectoryMonitor GPollFileMonitor)) '(created deleted stopped)) ((string-equal (file-notify--test-library) "kqueue") '(created changed deleted stopped)) ;; GKqueueFileMonitor does not report the `changed' event. - ((equal (file-notify--test-monitor) 'GKqueueFileMonitor) + ((eq (file-notify--test-monitor) 'GKqueueFileMonitor) '(created deleted deleted stopped)) (t '(created changed deleted deleted stopped))) (write-region @@ -762,15 +781,12 @@ delivered." '(created changed created changed changed changed changed deleted deleted)) - ;; gvfs-monitor-dir on cygwin does not detect the - ;; `created' event reliably. - ((string-equal - (file-notify--test-library) "gvfs-monitor-dir.exe") - '((deleted stopped) - (created created deleted stopped))) ;; There are three `deleted' events, for two files and - ;; for the directory. Except for cygwin and kqueue. - ((eq system-type 'cygwin) + ;; for the directory. Except for + ;; GFam{File,Directory}Monitor, GPollFileMonitor and + ;; kqueue. + ((memq (file-notify--test-monitor) + '(GFamFileMonitor GFamDirectoryMonitor GPollFileMonitor)) '(created created changed changed deleted stopped)) ((string-equal (file-notify--test-library) "kqueue") '(created changed created changed deleted stopped)) @@ -779,7 +795,7 @@ delivered." ((getenv "EMACS_EMBA_CI") '(created changed created changed deleted deleted)) ;; GKqueueFileMonitor does not report the `changed' event. - ((equal (file-notify--test-monitor) 'GKqueueFileMonitor) + ((eq (file-notify--test-monitor) 'GKqueueFileMonitor) '(created created deleted deleted deleted stopped)) (t '(created changed created changed deleted deleted deleted stopped))) @@ -819,26 +835,23 @@ delivered." ;; events for the watched directory. ((string-equal (file-notify--test-library) "w32notify") '(created changed renamed deleted)) - ;; gvfs-monitor-dir on cygwin does not detect the - ;; `created' event reliably. - ((string-equal - (file-notify--test-library) "gvfs-monitor-dir.exe") - '((deleted stopped) - (created deleted stopped))) ;; On emba, `deleted' and `stopped' events of the ;; directory are not detected. ((getenv "EMACS_EMBA_CI") '(created changed renamed deleted)) ;; There are two `deleted' events, for the file and for - ;; the directory. Except for cygwin and kqueue. And - ;; cygwin raises `created' and `deleted' events instead - ;; of a `renamed' event. - ((eq system-type 'cygwin) + ;; the directory. Except for + ;; GFam{File,Directory}Monitor, GPollfileMonitor and + ;; kqueue. And GFam{File,Directory}Monitor and + ;; GPollFileMonitor raise `created' and `deleted' events + ;; instead of a `renamed' event. + ((memq (file-notify--test-monitor) + '(GFamFileMonitor GFamDirectoryMonitor GPollFileMonitor)) '(created created deleted deleted stopped)) ((string-equal (file-notify--test-library) "kqueue") '(created changed renamed deleted stopped)) ;; GKqueueFileMonitor does not report the `changed' event. - ((equal (file-notify--test-monitor) 'GKqueueFileMonitor) + ((eq (file-notify--test-monitor) 'GKqueueFileMonitor) '(created renamed deleted deleted stopped)) (t '(created changed renamed deleted deleted stopped))) (write-region @@ -857,8 +870,8 @@ delivered." (file-notify--test-cleanup)) (unwind-protect - ;; Check attribute change. Does not work for cygwin. - (unless (eq system-type 'cygwin) + ;; Check attribute change. + (progn (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) @@ -876,12 +889,21 @@ delivered." ((string-equal (file-notify--test-library) "w32notify") '((changed changed) (changed changed changed changed))) - ;; GKqueueFileMonitor does not report the `attribute-changed' event. - ((equal (file-notify--test-monitor) 'GKqueueFileMonitor) nil) - ;; For kqueue and in the remote case, `write-region' - ;; raises also an `attribute-changed' event. - ((or (string-equal (file-notify--test-library) "kqueue") - (file-remote-p temporary-file-directory)) + ;; GFam{File,Directory}Monitor, GKqueueFileMonitor and + ;; GPollFileMonitor do not report the `attribute-changed' + ;; event. + ((memq (file-notify--test-monitor) + '(GFamFileMonitor GFamDirectoryMonitor + GKqueueFileMonitor GPollFileMonitor)) + '()) + ;; For GInotifyFileMonitor,`write-region' raises + ;; also an `attribute-changed' event on gio. + ((and (string-equal (file-notify--test-library) "gio") + (eq (file-notify--test-monitor) 'GInotifyFileMonitor)) + '(attribute-changed attribute-changed attribute-changed)) + ;; For kqueue, `write-region' raises also an + ;; `attribute-changed' event. + ((string-equal (file-notify--test-library) "kqueue") '(attribute-changed attribute-changed attribute-changed)) (t '(attribute-changed attribute-changed))) (write-region @@ -946,7 +968,7 @@ delivered." ;; GKqueueFileMonitor does not report the `changed' event. (skip-unless - (not (equal (file-notify--test-monitor) 'GKqueueFileMonitor))) + (not (eq (file-notify--test-monitor) 'GKqueueFileMonitor))) ;; Check, that file notification has been used. (should auto-revert-mode) @@ -1046,13 +1068,14 @@ delivered." (should (file-notify-valid-p file-notify--test-desc)) (file-notify--test-with-actions (cond - ;; gvfs-monitor-dir on cygwin does not detect the - ;; `changed' event reliably. - ((string-equal (file-notify--test-library) "gvfs-monitor-dir.exe") + ;; GFam{File,Directory}Monitor do not + ;; detect the `changed' event reliably. + ((memq (file-notify--test-monitor) + '(GFamFileMonitor GFamDirectoryMonitor)) '((deleted stopped) (changed deleted stopped))) ;; GKqueueFileMonitor does not report the `changed' event. - ((equal (file-notify--test-monitor) 'GKqueueFileMonitor) + ((eq (file-notify--test-monitor) 'GKqueueFileMonitor) '(deleted stopped)) ;; There could be one or two `changed' events. (t '((changed deleted stopped) @@ -1090,21 +1113,18 @@ delivered." ;; events for the watched directory. ((string-equal (file-notify--test-library) "w32notify") '(created changed deleted)) - ;; gvfs-monitor-dir on cygwin does not detect the - ;; `created' event reliably. - ((string-equal - (file-notify--test-library) "gvfs-monitor-dir.exe") - '((deleted stopped) - (created deleted stopped))) ;; There are two `deleted' events, for the file and for - ;; the directory. Except for cygwin and kqueue. And - ;; cygwin does not raise a `changed' event. - ((eq system-type 'cygwin) + ;; the directory. Except for + ;; GFam{File,Directory}Monitor, GPollFileMonitor and + ;; kqueue. And GFam{File,Directory}Monitor and + ;; GPollfileMonitor do not raise a `changed' event. + ((memq (file-notify--test-monitor) + '(GFamFileMonitor GFamDirectoryMonitor GPollFileMonitor)) '(created deleted stopped)) ((string-equal (file-notify--test-library) "kqueue") '(created changed deleted stopped)) ;; GKqueueFileMonitor does not report the `changed' event. - ((equal (file-notify--test-monitor) 'GKqueueFileMonitor) + ((eq (file-notify--test-monitor) 'GKqueueFileMonitor) '(created deleted deleted stopped)) (t '(created changed deleted deleted stopped))) (write-region @@ -1205,7 +1225,7 @@ delivered." file-notify--test-tmpfile '(change) #'file-notify--test-event-handler))) (unwind-protect - (let ((n 1000) + (let ((n 10);00) source-file-list target-file-list (default-directory file-notify--test-tmpfile)) (dotimes (i n) @@ -1234,9 +1254,11 @@ delivered." (dotimes (_i n) (setq r (append '(deleted renamed) r))) r)) - ;; cygwin fires `changed' and `deleted' events, sometimes - ;; in random order. - ((eq system-type 'cygwin) + ;; GFam{File,Directory}Monitor and GPollFileMonitor fire + ;; `changed' and `deleted' events, sometimes in random + ;; order. + ((memq (file-notify--test-monitor) + '(GFamFileMonitor GFamDirectoryMonitor GPollFileMonitor)) (let (r) (dotimes (_i n) (setq r (append '(changed deleted) r))) @@ -1285,7 +1307,7 @@ delivered." (file-notify--test-with-actions (cond ;; GKqueueFileMonitor does not report the `changed' event. - ((equal (file-notify--test-monitor) 'GKqueueFileMonitor) nil) + ((eq (file-notify--test-monitor) 'GKqueueFileMonitor) '()) ;; There could be one or two `changed' events. (t '((changed) (changed changed)))) @@ -1323,11 +1345,13 @@ delivered." (should (file-notify-valid-p file-notify--test-desc)) (file-notify--test-with-actions (cond - ;; On cygwin we only get the `changed' event. - ((eq system-type 'cygwin) - '(changed)) + ;; GFam{File,Directory}Monitor and GPollFileMonitor + ;; report only the `changed' event. + ((memq (file-notify--test-monitor) + '(GFamFileMonitor GFamDirectoryMonitor GPollFileMonitor)) + '(changed)) ;; GKqueueFileMonitor does not report the `changed' event. - ((equal (file-notify--test-monitor) 'GKqueueFileMonitor) + ((eq (file-notify--test-monitor) 'GKqueueFileMonitor) '(renamed created)) (t '(renamed created changed))) ;; The file is renamed when creating a backup. It shall @@ -1398,7 +1422,7 @@ the file watch." (should (file-notify-valid-p file-notify--test-desc1)) (should (file-notify-valid-p file-notify--test-desc2)) (should-not (equal file-notify--test-desc1 file-notify--test-desc2)) - (let ((n 100)) + (let ((n 10));0)) ;; Run the test. (file-notify--test-with-actions ;; There could be one or two `changed' events. @@ -1455,10 +1479,13 @@ the file watch." ;; Now we delete the directory. (file-notify--test-with-actions (cond - ;; In kqueue and for cygwin, just one `deleted' event for - ;; the directory is received. - ((or (eq system-type 'cygwin) - (string-equal (file-notify--test-library) "kqueue")) + ;; GFam{File,Directory}Monitor, GPollFileMonitor and + ;; kqueue raise just one `deleted' event for the + ;; directory. + ((memq (file-notify--test-monitor) + '(GFamFileMonitor GFamDirectoryMonitor GPollFileMonitor)) + '(deleted stopped)) + ((string-equal (file-notify--test-library) "kqueue") '(deleted stopped)) (t (append ;; The directory monitor raises a `deleted' event for -- cgit v1.2.3 From 97992a342be65cd448dd115e75686d269734bf68 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Wed, 31 Mar 2021 11:37:35 +0200 Subject: ; * lisp/net/tramp-sh.el (tramp-sh-gio-monitor-process-filter): ; Instrument for emba. --- lisp/net/tramp-sh.el | 2 ++ 1 file changed, 2 insertions(+) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 1764f2ef03f..c2dab64d5bf 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -3750,6 +3750,8 @@ Fall back to normal file name handler if no Tramp handler exists." ;; Determine monitor name. (unless (tramp-connection-property-p proc "gio-file-monitor") + (when (getenv "EMACS_EMBA_CI") + (message "%s" string)) (cond ;; We have seen this only on cygwin gio, which uses the ;; GPollFileMonitor. -- cgit v1.2.3 From 0f5bd3b7fa01a53bd170da90e556827f3e7f21bb Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Wed, 31 Mar 2021 21:09:55 +0200 Subject: * lisp/net/tramp-sh.el (tramp-sh-gio-monitor-process-filter): Make assumption for emba. --- lisp/net/tramp-sh.el | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index c2dab64d5bf..6440e577a9b 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -3740,6 +3740,8 @@ Fall back to normal file name handler if no Tramp handler exists." "changes done" "changes-done-hint" string) string (tramp-compat-string-replace "renamed to" "moved" string)) + (when (getenv "EMACS_EMBA_CI") + (message "%s" string)) (catch 'doesnt-work ;; https://bugs.launchpad.net/bugs/1742946 @@ -3750,15 +3752,18 @@ Fall back to normal file name handler if no Tramp handler exists." ;; Determine monitor name. (unless (tramp-connection-property-p proc "gio-file-monitor") - (when (getenv "EMACS_EMBA_CI") - (message "%s" string)) (cond - ;; We have seen this only on cygwin gio, which uses the - ;; GPollFileMonitor. + ;; We have seen this on cygwin gio and on emba. Let's make some assumptions. ((string-match "Can't find module 'help' specified in GIO_USE_FILE_MONITOR" string) - (tramp-set-connection-property - proc "gio-file-monitor" 'GPollFileMonitor)) + (cond + ((getenv "EMACS_EMBA_CI") + (tramp-set-connection-property + proc "gio-file-monitor" 'GInotifyMonitor)) + ((eq system-type 'cygwin) + (tramp-set-connection-property + proc "gio-file-monitor" 'GPollFileMonitor)) + (t (tramp-error proc 'file-error "Cannot determine gio monitor")))) ;; TODO: What happens, if several monitor names are reported? ((string-match "\ Supported arguments for GIO_USE_FILE_MONITOR environment variable: -- cgit v1.2.3 From ed320ebe2859530254f28d481cd164e1553fe607 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Wed, 31 Mar 2021 21:12:09 +0200 Subject: ; Fix last change --- lisp/net/tramp-sh.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 6440e577a9b..73e0807dbc1 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -3759,7 +3759,7 @@ Fall back to normal file name handler if no Tramp handler exists." (cond ((getenv "EMACS_EMBA_CI") (tramp-set-connection-property - proc "gio-file-monitor" 'GInotifyMonitor)) + proc "gio-file-monitor" 'GInotifyFileMonitor)) ((eq system-type 'cygwin) (tramp-set-connection-property proc "gio-file-monitor" 'GPollFileMonitor)) -- cgit v1.2.3 From 860bc0db1cdf4ec58299013074edb3a3925f9dce Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 3 Apr 2021 12:26:14 +0200 Subject: * test/lisp/filenotify-tests.el (file-notify--test-timeout): Change timing. ; * lisp/net/tramp-sh.el (tramp-sh-gio-monitor-process-filter): ; Remove test message. --- lisp/net/tramp-sh.el | 2 -- test/lisp/filenotify-tests.el | 2 +- 2 files changed, 1 insertion(+), 3 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 73e0807dbc1..255314a99ea 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -3740,8 +3740,6 @@ Fall back to normal file name handler if no Tramp handler exists." "changes done" "changes-done-hint" string) string (tramp-compat-string-replace "renamed to" "moved" string)) - (when (getenv "EMACS_EMBA_CI") - (message "%s" string)) (catch 'doesnt-work ;; https://bugs.launchpad.net/bugs/1742946 diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index 4a2f1f9a676..cca8aeb97d4 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -117,8 +117,8 @@ There are different timeouts for local and remote file notification libraries." (defun file-notify--test-timeout () "Timeout to wait for arriving a bunch of events, in seconds." (cond + ((file-remote-p temporary-file-directory) 20) ((eq system-type 'cygwin) 10) - ((file-remote-p temporary-file-directory) 6) ((string-equal (file-notify--test-library) "w32notify") 4) (t 3))) -- cgit v1.2.3 From 4eca3bd8df9a1092d322eb6af7108a3ea27c21b1 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 3 Apr 2021 18:25:27 +0200 Subject: * lisp/net/tramp-sh.el (tramp-sh-handle-insert-directory): Fix code finding //DIRED//. --- lisp/net/tramp-sh.el | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 255314a99ea..c3e1745d2f2 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2584,12 +2584,9 @@ The method used must be an out-of-band method." (save-restriction (narrow-to-region beg-marker end-marker) ;; Check for "--dired" output. - (forward-line -2) - (when (looking-at-p "//SUBDIRED//") - (forward-line -1)) - (when (looking-at "//DIRED//\\s-+") - (let ((beg (match-end 0)) - (end (point-at-eol))) + (when (re-search-backward "^//DIRED//\\s-+\\(.+\\)$" nil 'noerror) + (let ((beg (match-beginning 1)) + (end (match-end 0))) ;; Now read the numeric positions of file names. (goto-char beg) (while (< (point) end) @@ -2599,7 +2596,7 @@ The method used must be an out-of-band method." ;; End is followed by \n or by " -> ". (put-text-property start end 'dired-filename t)))))) ;; Remove trailing lines. - (goto-char (point-at-bol)) + (beginning-of-line) (while (looking-at "//") (forward-line 1) (delete-region (match-beginning 0) (point)))) -- cgit v1.2.3 From 14d295871a93c37a33d558ec4e8d49a93b787d8e Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Mon, 5 Apr 2021 19:37:30 +0200 Subject: Use powershell for Tramp on MS Windows * lisp/net/tramp-sh.el (tramp-use-ssh-controlmaster-options): Nil on MS Windows. (tramp-connection-properties): Add "encoding-shell". (tramp-maybe-open-connection): Use it. Change exit handling. (tramp-actions-before-shell): Add `tramp-no-job-control-regexp'. * lisp/net/tramp.el (tramp-methods): Adapt docstring. (tramp-no-job-control-regexp): New defcustom. (tramp-get-debug-buffer): Set coding system. --- lisp/net/tramp-sh.el | 37 ++++++++++++++++++++++--------------- lisp/net/tramp.el | 25 ++++++++++++++++++------- 2 files changed, 40 insertions(+), 22 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index c3e1745d2f2..499bf8abe41 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -103,12 +103,12 @@ detected as prompt when being sent on echoing hosts, therefore.") (defconst tramp-end-of-heredoc (md5 tramp-end-of-output) "String used to recognize end of heredoc strings.") -(defcustom tramp-use-ssh-controlmaster-options t +(defcustom tramp-use-ssh-controlmaster-options (not (eq system-type 'windows-nt)) "Whether to use `tramp-ssh-controlmaster-options'. Set it to nil, if you use Control* or Proxy* options in your ssh configuration." :group 'tramp - :version "24.4" + :version "28.1" :type 'boolean) (defvar tramp-ssh-controlmaster-options nil @@ -389,7 +389,14 @@ The string is used in `tramp-methods'.") (regexp-opt '("rcp" "remcp" "rsh" "telnet" "nc" "krlogin" "fcp")) "\\'") - nil ,(user-login-name)))) + nil ,(user-login-name))) + + ;; MS Windows Openssh client does not cooperate well with cmdproxy. + (when-let ((encoding-shell + (and (eq system-type 'windows-nt) (executable-find "powershell")))) + (add-to-list 'tramp-connection-properties + `(,(regexp-opt '("/sshx:" "/scpx:")) + "encoding-shell" ,encoding-shell)))) ;;;###tramp-autoload (defconst tramp-completion-function-alist-rsh @@ -484,6 +491,7 @@ shell from reading its init file." '((tramp-login-prompt-regexp tramp-action-login) (tramp-password-prompt-regexp tramp-action-password) (tramp-wrong-passwd-regexp tramp-action-permission-denied) + (tramp-no-job-control-regexp tramp-action-permission-denied) (shell-prompt-pattern tramp-action-succeed) (tramp-shell-prompt-pattern tramp-action-succeed) (tramp-yesno-prompt-regexp tramp-action-yesno) @@ -4857,8 +4865,6 @@ connection if a previous connection has died for some reason." (setenv "HISTSIZE" "0")))) (setenv "PROMPT_COMMAND") (setenv "PS1" tramp-initial-end-of-output) - (unless (stringp tramp-encoding-shell) - (tramp-error vec 'file-error "`tramp-encoding-shell' not set")) (let* ((current-host tramp-system-name) (target-alist (tramp-compute-multi-hops vec)) ;; We will apply `tramp-ssh-controlmaster-options' @@ -4870,17 +4876,23 @@ connection if a previous connection has died for some reason." ;; W32 systems. (process-coding-system-alist nil) (coding-system-for-read nil) - (extra-args (tramp-get-sh-extra-args tramp-encoding-shell)) + (encoding-shell + (tramp-get-connection-property + vec "encoding-shell" tramp-encoding-shell)) + (extra-args (tramp-get-sh-extra-args encoding-shell)) ;; This must be done in order to avoid our file ;; name handler. (p (let ((default-directory (tramp-compat-temporary-file-directory))) + (unless (stringp encoding-shell) + (tramp-error + vec 'file-error "`tramp-encoding-shell' not set")) (apply #'start-process (tramp-get-connection-name vec) (tramp-get-connection-buffer vec) (append - (list tramp-encoding-shell) + (list encoding-shell) (and extra-args (split-string extra-args)) (and tramp-encoding-command-interactive (list tramp-encoding-command-interactive))))))) @@ -4899,8 +4911,7 @@ connection if a previous connection has died for some reason." ;; Check whether process is alive. (tramp-barf-if-no-shell-prompt - p 10 - "Couldn't find local shell prompt for %s" tramp-encoding-shell) + p 10 "Couldn't find local shell prompt for %s" encoding-shell) ;; Now do all the connections as specified. (while target-alist @@ -4974,12 +4985,8 @@ connection if a previous connection has died for some reason." ?h (or l-host "") ?u (or l-user "") ?p (or l-port "") ?c (format-spec options (format-spec-make ?t tmpfile)) ?l (concat remote-shell " " extra-args " -i")) - ;; Local shell could be a Windows COMSPEC. It - ;; doesn't know the ";" syntax, but we must - ;; exit always for `start-file-process'. It - ;; could also be a restricted shell, which does - ;; not allow "exec". - (when r-shell '("&&" "exit" "||" "exit"))) + ;; A restricted shell does not allow "exec". + (when r-shell '("; exit"))) " ")) ;; Send the command. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 8141f026f74..99955b54598 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -354,12 +354,13 @@ Notes: All these arguments can be overwritten by connection properties. See Info node `(tramp) Predefined connection information'. -When using `su' or `sudo' the phrase \"open connection to a remote -host\" sounds strange, but it is used nevertheless, for consistency. -No connection is opened to a remote host, but `su' or `sudo' is -started on the local host. You should specify a remote host -`localhost' or the name of the local host. Another host name is -useful only in combination with `tramp-default-proxies-alist'.") +When using `su', `sudo' or `doas' the phrase \"open connection to +a remote host\" sounds strange, but it is used nevertheless, for +consistency. No connection is opened to a remote host, but `su', +`sudo' or `doas' is started on the local host. You should +specify a remote host `localhost' or the name of the local host. +Another host name is useful only in combination with +`tramp-default-proxies-alist'.") (defcustom tramp-default-method ;; An external copy method seems to be preferred, because it performs @@ -690,6 +691,15 @@ The regexp should match at end of buffer." :version "27.1" :type 'regexp) +;; Powershell requires "ssh -t -t" for terminal emulation. If it +;; doesn't fit, there is an error. +(defcustom tramp-no-job-control-regexp + (regexp-quote "Thus no job control in this shell.") + "Regular expression matching powershell's job control message. +The regexp should match at end of buffer." + :version "28.1" + :type 'regexp) + (defcustom tramp-operation-not-permitted-regexp (concat "\\(" "preserving times.*" "\\|" "set mode" "\\)" ":\\s-*" (regexp-opt '("Operation not permitted") t)) @@ -1808,6 +1818,7 @@ The outline level is equal to the verbosity of the Tramp message." "Get the debug buffer for VEC." (with-current-buffer (get-buffer-create (tramp-debug-buffer-name vec)) (when (bobp) + (set-buffer-file-coding-system 'utf-8) (setq buffer-undo-list t) ;; Activate `outline-mode'. This runs `text-mode-hook' and ;; `outline-mode-hook'. We must prevent that local processes @@ -1848,7 +1859,7 @@ ARGUMENTS to actually emit the message (if applicable)." (when (bobp) (insert (format - ";; Emacs: %s Tramp: %s -*- mode: outline; -*-" + ";; Emacs: %s Tramp: %s -*- mode: outline; coding: utf-8; -*-" emacs-version tramp-version)) (when (>= tramp-verbose 10) (let ((tramp-verbose 0)) -- cgit v1.2.3 From 738266240dc1a19911770bf676330aa72352da79 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Tue, 6 Apr 2021 09:50:07 +0200 Subject: Fix Bug#47601 in Tramp * lisp/net/tramp-sh.el (tramp-sh-file-name-handler-alist): Use `tramp-handle-file-newer-than-file-p'. (Bug#47601) (tramp-sh-handle-file-newer-than-file-p, tramp-run-test2): Remove. --- lisp/net/tramp-sh.el | 63 +--------------------------------------------------- 1 file changed, 1 insertion(+), 62 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 499bf8abe41..b902ee6f352 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -949,7 +949,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (file-name-directory . tramp-handle-file-name-directory) (file-name-nondirectory . tramp-handle-file-name-nondirectory) ;; `file-name-sans-versions' performed by default handler. - (file-newer-than-file-p . tramp-sh-handle-file-newer-than-file-p) + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) (file-notify-add-watch . tramp-sh-handle-file-notify-add-watch) (file-notify-rm-watch . tramp-handle-file-notify-rm-watch) (file-notify-valid-p . tramp-handle-file-notify-valid-p) @@ -1557,49 +1557,6 @@ ID-FORMAT valid values are `string' and `integer'." (or (tramp-check-cached-permissions v ?r) (tramp-run-test "-r" filename))))) -;; When the remote shell is started, it looks for a shell which groks -;; tilde expansion. Here, we assume that all shells which grok tilde -;; expansion will also provide a `test' command which groks `-nt' (for -;; newer than). If this breaks, tell me about it and I'll try to do -;; something smarter about it. -(defun tramp-sh-handle-file-newer-than-file-p (file1 file2) - "Like `file-newer-than-file-p' for Tramp files." - (cond ((not (file-exists-p file1)) nil) - ((not (file-exists-p file2)) t) - (t ;; We are sure both files exist at this point. We try to - ;; get the mtime of both files. If they are not equal to - ;; the "dont-know" value, then we subtract the times and - ;; obtain the result. - (let ((fa1 (file-attributes file1)) - (fa2 (file-attributes file2))) - (if (and - (not - (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time fa1) - tramp-time-dont-know)) - (not - (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time fa2) - tramp-time-dont-know))) - (time-less-p - (tramp-compat-file-attribute-modification-time fa2) - (tramp-compat-file-attribute-modification-time fa1)) - ;; If one of them is the dont-know value, then we can - ;; still try to run a shell command on the remote host. - ;; However, this only works if both files are Tramp - ;; files and both have the same method, same user, same - ;; host. - (unless (tramp-equal-remote file1 file2) - (with-parsed-tramp-file-name - (if (tramp-tramp-file-p file1) file1 file2) nil - (tramp-error - v 'file-error - "Files %s and %s must have same method, user, host" - file1 file2))) - (with-parsed-tramp-file-name file1 nil - (tramp-run-test2 - (tramp-get-test-nt-command v) file1 file2))))))) - ;; Functions implemented using the basic functions above. (defun tramp-sh-handle-file-directory-p (filename) @@ -3959,24 +3916,6 @@ Returns the exit code of the `test' program." switch (tramp-shell-quote-argument localname))))) -(defun tramp-run-test2 (format-string file1 file2) - "Run `test'-like program on the remote system, given FILE1, FILE2. -FORMAT-STRING contains the program name, switches, and place holders. -Returns the exit code of the `test' program. Barfs if the methods, -hosts, or files, disagree." - (unless (tramp-equal-remote file1 file2) - (with-parsed-tramp-file-name (if (tramp-tramp-file-p file1) file1 file2) nil - (tramp-error - v 'file-error - "tramp-run-test2 only implemented for same method, user, host"))) - (with-parsed-tramp-file-name file1 v1 - (with-parsed-tramp-file-name file1 v2 - (tramp-send-command-and-check - v1 - (format format-string - (tramp-shell-quote-argument v1-localname) - (tramp-shell-quote-argument v2-localname)))))) - (defconst tramp-sunos-unames (regexp-opt '("SunOS 5.10" "SunOS 5.11")) "Regexp to determine remote SunOS.") -- cgit v1.2.3 From 9e8ac1f5be755a5618792b5b100915c2730c9d61 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Thu, 8 Apr 2021 12:24:42 +0200 Subject: Revert use of powershell in Tramp, there are collateral damages * lisp/net/tramp-sh.el (tramp-methods) : Fix quoting for MS Windows. (tramp-connection-properties): Don't set "encoding-shell". (tramp-actions-before-shell): Remove `tramp-no-job-control-regexp'. (tramp-maybe-open-connection): Revert changes for "encoding-shell". * lisp/net/tramp.el (tramp-no-job-control-regexp): Remove. --- lisp/net/tramp-sh.el | 33 ++++++++++++--------------------- lisp/net/tramp.el | 9 --------- 2 files changed, 12 insertions(+), 30 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index b902ee6f352..8db9dd9d822 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -169,7 +169,8 @@ The string is used in `tramp-methods'.") (tramp-login-program "ssh") (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") ("-e" "none") ("-t" "-t") - ("-o" "RemoteCommand='%l'") ("%h"))) + ("-o" "RemoteCommand=\"%l\"") + ("%h"))) (tramp-async-args (("-q"))) (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) @@ -225,7 +226,8 @@ The string is used in `tramp-methods'.") (tramp-login-program "ssh") (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") ("-e" "none") ("-t" "-t") - ("-o" "RemoteCommand='%l'") ("%h"))) + ("-o" "RemoteCommand=\"%l\"") + ("%h"))) (tramp-async-args (("-q"))) (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) @@ -389,14 +391,7 @@ The string is used in `tramp-methods'.") (regexp-opt '("rcp" "remcp" "rsh" "telnet" "nc" "krlogin" "fcp")) "\\'") - nil ,(user-login-name))) - - ;; MS Windows Openssh client does not cooperate well with cmdproxy. - (when-let ((encoding-shell - (and (eq system-type 'windows-nt) (executable-find "powershell")))) - (add-to-list 'tramp-connection-properties - `(,(regexp-opt '("/sshx:" "/scpx:")) - "encoding-shell" ,encoding-shell)))) + nil ,(user-login-name)))) ;;;###tramp-autoload (defconst tramp-completion-function-alist-rsh @@ -491,7 +486,6 @@ shell from reading its init file." '((tramp-login-prompt-regexp tramp-action-login) (tramp-password-prompt-regexp tramp-action-password) (tramp-wrong-passwd-regexp tramp-action-permission-denied) - (tramp-no-job-control-regexp tramp-action-permission-denied) (shell-prompt-pattern tramp-action-succeed) (tramp-shell-prompt-pattern tramp-action-succeed) (tramp-yesno-prompt-regexp tramp-action-yesno) @@ -4804,6 +4798,8 @@ connection if a previous connection has died for some reason." (setenv "HISTSIZE" "0")))) (setenv "PROMPT_COMMAND") (setenv "PS1" tramp-initial-end-of-output) + (unless (stringp tramp-encoding-shell) + (tramp-error vec 'file-error "`tramp-encoding-shell' not set")) (let* ((current-host tramp-system-name) (target-alist (tramp-compute-multi-hops vec)) ;; We will apply `tramp-ssh-controlmaster-options' @@ -4815,23 +4811,17 @@ connection if a previous connection has died for some reason." ;; W32 systems. (process-coding-system-alist nil) (coding-system-for-read nil) - (encoding-shell - (tramp-get-connection-property - vec "encoding-shell" tramp-encoding-shell)) - (extra-args (tramp-get-sh-extra-args encoding-shell)) + (extra-args (tramp-get-sh-extra-args tramp-encoding-shell)) ;; This must be done in order to avoid our file ;; name handler. (p (let ((default-directory (tramp-compat-temporary-file-directory))) - (unless (stringp encoding-shell) - (tramp-error - vec 'file-error "`tramp-encoding-shell' not set")) (apply #'start-process (tramp-get-connection-name vec) (tramp-get-connection-buffer vec) (append - (list encoding-shell) + (list tramp-encoding-shell) (and extra-args (split-string extra-args)) (and tramp-encoding-command-interactive (list tramp-encoding-command-interactive))))))) @@ -4850,7 +4840,8 @@ connection if a previous connection has died for some reason." ;; Check whether process is alive. (tramp-barf-if-no-shell-prompt - p 10 "Couldn't find local shell prompt for %s" encoding-shell) + p 10 + "Couldn't find local shell prompt for %s" tramp-encoding-shell) ;; Now do all the connections as specified. (while target-alist @@ -4925,7 +4916,7 @@ connection if a previous connection has died for some reason." ?c (format-spec options (format-spec-make ?t tmpfile)) ?l (concat remote-shell " " extra-args " -i")) ;; A restricted shell does not allow "exec". - (when r-shell '("; exit"))) + (when r-shell '("&&" "exit" "||" "exit"))) " ")) ;; Send the command. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 99955b54598..b2c650f6e1a 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -691,15 +691,6 @@ The regexp should match at end of buffer." :version "27.1" :type 'regexp) -;; Powershell requires "ssh -t -t" for terminal emulation. If it -;; doesn't fit, there is an error. -(defcustom tramp-no-job-control-regexp - (regexp-quote "Thus no job control in this shell.") - "Regular expression matching powershell's job control message. -The regexp should match at end of buffer." - :version "28.1" - :type 'regexp) - (defcustom tramp-operation-not-permitted-regexp (concat "\\(" "preserving times.*" "\\|" "set mode" "\\)" ":\\s-*" (regexp-opt '("Operation not permitted") t)) -- cgit v1.2.3 From ca1ddef2627e2d71539467c9042f78d9d560ea9d Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 10 Apr 2021 14:46:58 +0200 Subject: Tramp: fix location of files on W32 * lisp/net/tramp.el: * lisp/net/tramp-sh.el: Use (eq system-type 'windows-nt) where appropriate. (tramp-completion-function-alist-ssh): Fix location of files on W32. --- lisp/net/tramp-sh.el | 34 ++++++++++++++++++++++++++-------- lisp/net/tramp.el | 8 ++++---- 2 files changed, 30 insertions(+), 12 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 8db9dd9d822..0e6a2bb04af 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -401,16 +401,34 @@ The string is used in `tramp-methods'.") ;;;###tramp-autoload (defconst tramp-completion-function-alist-ssh - '((tramp-parse-rhosts "/etc/hosts.equiv") + `((tramp-parse-rhosts "/etc/hosts.equiv") (tramp-parse-rhosts "/etc/shosts.equiv") - (tramp-parse-shosts "/etc/ssh_known_hosts") - (tramp-parse-sconfig "/etc/ssh_config") + ;; On W32 systems, the ssh directory is located somewhere else. + (tramp-parse-shosts ,(expand-file-name + "ssh/ssh_known_hosts" + (or (and (eq system-type 'windows-nt) + (getenv "ProgramData")) + "/etc/"))) + (tramp-parse-sconfig ,(expand-file-name + "ssh/ssh_config" + (or (and (eq system-type 'windows-nt) + (getenv "ProgramData")) + "/etc/"))) (tramp-parse-shostkeys "/etc/ssh2/hostkeys") (tramp-parse-sknownhosts "/etc/ssh2/knownhosts") (tramp-parse-rhosts "~/.rhosts") (tramp-parse-rhosts "~/.shosts") - (tramp-parse-shosts "~/.ssh/known_hosts") - (tramp-parse-sconfig "~/.ssh/config") + ;; On W32 systems, the .ssh directory is located somewhere else. + (tramp-parse-shosts ,(expand-file-name + ".ssh/known_hosts" + (or (and (eq system-type 'windows-nt) + (getenv "USERPROFILE")) + "~/"))) + (tramp-parse-sconfig ,(expand-file-name + ".ssh/config" + (or (and (eq system-type 'windows-nt) + (getenv "USERPROFILE")) + "~/"))) (tramp-parse-shostkeys "~/.ssh2/hostkeys") (tramp-parse-sknownhosts "~/.ssh2/knownhosts")) "Default list of (FUNCTION FILE) pairs to be examined for ssh methods.") @@ -433,7 +451,7 @@ The string is used in `tramp-methods'.") ;;;###tramp-autoload (defconst tramp-completion-function-alist-putty `((tramp-parse-putty - ,(if (memq system-type '(windows-nt)) + ,(if (eq system-type 'windows-nt) "HKEY_CURRENT_USER\\Software\\SimonTatham\\PuTTY\\Sessions" "~/.putty/sessions"))) "Default list of (FUNCTION REGISTRY) pairs to be examined for putty sessions.") @@ -5764,7 +5782,7 @@ function cell is returned to be applied on a buffer." ;; slashes as directory separators. (cond ((and (string-match-p "local" prop) - (memq system-type '(windows-nt))) + (eq system-type 'windows-nt)) "(%s | \"%s\")") ((string-match-p "local" prop) "(%s | %s)") (t "(%s | %s >%%s)")) @@ -5775,7 +5793,7 @@ function cell is returned to be applied on a buffer." ;; the pipe symbol be quoted if they use forward ;; slashes as directory separators. (if (and (string-match-p "local" prop) - (memq system-type '(windows-nt))) + (eq system-type 'windows-nt)) "(%s <%%s | \"%s\")" "(%s <%%s | %s)") compress coding)) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 578fa148a24..8da94ec9d9e 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -488,7 +488,7 @@ interpreted as a regular expression which always matches." ;; either lower case or upper case letters. See ;; . (defcustom tramp-restricted-shell-hosts-alist - (when (memq system-type '(windows-nt)) + (when (eq system-type 'windows-nt) (list (format "\\`\\(%s\\|%s\\)\\'" (regexp-quote (downcase tramp-system-name)) (regexp-quote (upcase tramp-system-name))))) @@ -558,7 +558,7 @@ usually suffice.") the remote shell.") (defcustom tramp-local-end-of-line - (if (memq system-type '(windows-nt)) "\r\n" "\n") + (if (eq system-type 'windows-nt) "\r\n" "\n") "String used for end of line in local processes." :version "24.1" :type 'string) @@ -3138,7 +3138,7 @@ User may be nil." (defun tramp-parse-putty (registry-or-dirname) "Return a list of (user host) tuples allowed to access. User is always nil." - (if (memq system-type '(windows-nt)) + (if (eq system-type 'windows-nt) (with-tramp-connection-property nil "parse-putty" (with-temp-buffer (when (zerop (tramp-call-process @@ -4990,7 +4990,7 @@ VEC is used for tracing." (let ((candidates '("en_US.utf8" "C.utf8" "en_US.UTF-8")) locale) (with-temp-buffer - (unless (or (memq system-type '(windows-nt)) + (unless (or (eq system-type 'windows-nt) (not (zerop (tramp-call-process nil "locale" nil t nil "-a")))) (while candidates -- cgit v1.2.3 From 8aaf13eae6a0edcaf6528ba0490ed351ef00e2b3 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Wed, 14 Apr 2021 13:25:36 +0200 Subject: Rearrange argument handling in Tramp scp calls. * lisp/net/tramp-sh.el (tramp-do-copy-or-rename-file-out-of-band): Use `start-process' instead of `start-process-shell-command'. (tramp-make-copy-program-file-name): Do not quote `localname'. * test/lisp/net/tramp-tests.el (tramp-method-out-of-band-p): Declare. (tramp--test-windows-nt-and-batch-p) (tramp--test-windows-nt-and-pscp-psftp-p): Remove, and also all callees. (tramp--test-windows-nt-and-out-of-band-p) (tramp--test-windows-nt-and-scp-p): New defuns. (tramp-test17-dired-with-wildcards) (tramp-test40-special-characters) (tramp-test40-special-characters-with-stat) (tramp-test40-special-characters-with-perl) (tramp-test40-special-characters-with-ls, tramp-test41-utf8) (tramp-test41-utf8-with-stat, tramp-test41-utf8-with-perl) (tramp-test41-utf8-with-ls): Use them. --- lisp/net/tramp-sh.el | 68 +++++++++++++++++++++++--------------------- test/lisp/net/tramp-tests.el | 40 +++++++++++++------------- 2 files changed, 55 insertions(+), 53 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 0e6a2bb04af..651444b9e03 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2218,7 +2218,7 @@ The method used must be an out-of-band method." (t2 (tramp-tramp-file-p newname)) (orig-vec (tramp-dissect-file-name (if t1 filename newname))) copy-program copy-args copy-env copy-keep-date listener spec - options source target remote-copy-program remote-copy-args) + options source target remote-copy-program remote-copy-args p) (with-parsed-tramp-file-name (if t1 filename newname) nil (if (and t1 t2) @@ -2253,10 +2253,10 @@ The method used must be an out-of-band method." #'identity) (if t1 (tramp-make-copy-program-file-name v) - (tramp-unquote-shell-quote-argument filename))) + (tramp-compat-file-name-unquote filename))) target (if t2 (tramp-make-copy-program-file-name v) - (tramp-unquote-shell-quote-argument newname))) + (tramp-compat-file-name-unquote newname))) ;; Check for user. There might be an interactive setting. (setq user (or (tramp-file-name-user v) @@ -2288,6 +2288,13 @@ The method used must be an out-of-band method." ;; keep-date argument is non-nil), or a replacement for ;; the whole keep-date sublist. (delete " " (apply #'tramp-expand-args v 'tramp-copy-args spec)) + ;; `tramp-ssh-controlmaster-options' is a string instead + ;; of a list. Unflatten it. + copy-args + (tramp-compat-flatten-tree + (mapcar + (lambda (x) (if (string-match-p " " x) (split-string x) x)) + copy-args)) copy-env (apply #'tramp-expand-args v 'tramp-copy-env spec) remote-copy-program (tramp-get-method-parameter v 'tramp-remote-copy-program) @@ -2349,31 +2356,26 @@ The method used must be an out-of-band method." copy-args (if remote-copy-program (list (if t1 (concat ">" target) (concat "<" source))) - (list source target)))) - - ;; Use an asynchronous process. By this, password can - ;; be handled. We don't set a timeout, because the - ;; copying of large files can last longer than 60 secs. - (let* ((command - (mapconcat - #'identity (append (list copy-program) copy-args) - " ")) - (p (let ((default-directory - (tramp-compat-temporary-file-directory))) - (start-process-shell-command - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - command)))) - (tramp-message orig-vec 6 "%s" command) - (process-put p 'vector orig-vec) - (process-put p 'adjust-window-size-function #'ignore) - (set-process-query-on-exit-flag p nil) - - ;; We must adapt `tramp-local-end-of-line' for - ;; sending the password. - (let ((tramp-local-end-of-line tramp-rsh-end-of-line)) - (tramp-process-actions - p v nil tramp-actions-copy-out-of-band)))) + (list source target))) + ;; Use an asynchronous process. By this, password + ;; can be handled. We don't set a timeout, because + ;; the copying of large files can last longer than 60 + ;; secs. + p (apply + #'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + copy-program copy-args)) + (tramp-message orig-vec 6 "%s" (string-join (process-command p) " ")) + (process-put p 'vector orig-vec) + (process-put p 'adjust-window-size-function #'ignore) + (set-process-query-on-exit-flag p nil) + + ;; We must adapt `tramp-local-end-of-line' for + ;; sending the password. + (let ((tramp-local-end-of-line tramp-rsh-end-of-line)) + (tramp-process-actions + p v nil tramp-actions-copy-out-of-band))) ;; Reset the transfer process properties. (tramp-flush-connection-property v "process-name") @@ -5221,15 +5223,17 @@ Return ATTR." (directory-file-name (tramp-file-name-unquote-localname vec)))) (when (string-match-p tramp-ipv6-regexp host) (setq host (format "[%s]" host))) + ;; This does not work yet for MS Windows scp, if there are + ;; characters to be quoted. Win32 OpenSSH 7.9 is said to support + ;; this, see + ;; (unless (string-match-p "ftp$" method) (setq localname (tramp-shell-quote-argument localname))) (cond ((tramp-get-method-parameter vec 'tramp-remote-copy-program) localname) - ((not (zerop (length user))) - (format - "%s@%s:%s" user host (tramp-unquote-shell-quote-argument localname))) - (t (format "%s:%s" host (tramp-unquote-shell-quote-argument localname)))))) + ((zerop (length user)) (format "%s:%s" host localname)) + (t (format "%s@%s:%s" user host localname))))) (defun tramp-method-out-of-band-p (vec size) "Return t if this is an out-of-band method, nil otherwise." diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index be428fc2a64..1eb0d0ec619 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -59,6 +59,7 @@ (declare-function tramp-get-remote-perl "tramp-sh") (declare-function tramp-get-remote-stat "tramp-sh") (declare-function tramp-list-tramp-buffers "tramp-cmds") +(declare-function tramp-method-out-of-band-p "tramp-sh") (declare-function tramp-smb-get-localname "tramp-smb") (defvar ange-ftp-make-backup-files) (defvar auto-save-file-name-transforms) @@ -3097,6 +3098,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) + (skip-unless (not (tramp--test-windows-nt-and-scp-p))) ;; Wildcards are not supported in tramp-crypt.el. (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 26.1. @@ -4369,7 +4371,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (delete-file tmp-name)))))) (defun tramp--test-shell-file-name () - "Return default remote shell.." + "Return default remote shell." (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh")) (ert-deftest tramp-test28-process-file () @@ -5838,18 +5840,18 @@ This requires restrictions of file name syntax." "Check, whether the locale host runs MS Windows." (eq system-type 'windows-nt)) -(defun tramp--test-windows-nt-and-batch-p () - "Check, whether the locale host runs MS Windows in batch mode. -This does not support special characters." - (and (eq system-type 'windows-nt) noninteractive)) +(defun tramp--test-windows-nt-and-out-of-band-p () + "Check, whether the locale host runs MS Windows and an out-of-band method. +This does not support utf8 based file transfer." + (and (eq system-type 'windows-nt) + (tramp-method-out-of-band-p tramp-test-vec 1))) -(defun tramp--test-windows-nt-and-pscp-psftp-p () - "Check, whether the locale host runs MS Windows, and ps{cp,ftp} is used. +(defun tramp--test-windows-nt-and-scp-p () + "Check, whether the locale host runs MS Windows, and scpx? is used. This does not support utf8 based file transfer." (and (eq system-type 'windows-nt) (string-match-p - (regexp-opt '("pscp" "psftp")) - (file-remote-p tramp-test-temporary-file-directory 'method)))) + "^scpx?" (file-remote-p tramp-test-temporary-file-directory 'method)))) (defun tramp--test-windows-nt-or-smb-p () "Check, whether the locale or remote host runs MS Windows. @@ -6112,7 +6114,7 @@ This requires restrictions of file name syntax." "Check special characters in file names." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) + (skip-unless (not (tramp--test-windows-nt-and-scp-p))) (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) (tramp--test-special-characters)) @@ -6124,7 +6126,7 @@ Use the `stat' command." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) + (skip-unless (not (tramp--test-windows-nt-and-scp-p))) ;; We cannot use `tramp-test-vec', because this fails during compilation. (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-stat v))) @@ -6143,7 +6145,7 @@ Use the `perl' command." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) + (skip-unless (not (tramp--test-windows-nt-and-scp-p))) ;; We cannot use `tramp-test-vec', because this fails during compilation. (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-perl v))) @@ -6165,7 +6167,7 @@ Use the `ls' command." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) + (skip-unless (not (tramp--test-windows-nt-and-scp-p))) (let ((tramp-connection-properties (append @@ -6230,8 +6232,7 @@ Use the `ls' command." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-batch-p))) - (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) + (skip-unless (not (tramp--test-windows-nt-and-out-of-band-p))) (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-gdrive-p))) (skip-unless (not (tramp--test-crypt-p))) @@ -6247,8 +6248,7 @@ Use the `stat' command." (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-batch-p))) - (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) + (skip-unless (not (tramp--test-windows-nt-and-out-of-band-p))) (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) ;; We cannot use `tramp-test-vec', because this fails during compilation. @@ -6270,8 +6270,7 @@ Use the `perl' command." (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-batch-p))) - (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) + (skip-unless (not (tramp--test-windows-nt-and-out-of-band-p))) (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) ;; We cannot use `tramp-test-vec', because this fails during compilation. @@ -6296,8 +6295,7 @@ Use the `ls' command." (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-batch-p))) - (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) + (skip-unless (not (tramp--test-windows-nt-and-out-of-band-p))) (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) -- cgit v1.2.3 From 3430c12154579103c3de991bcda4558ed46a485e Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 17 Apr 2021 16:39:14 +0200 Subject: Make stderr in Tramp's make-process more robust * lisp/net/tramp-sh.el (tramp-sh-handle-make-process): Wrap about error in inserting stderr file. * lisp/net/tramp.el (tramp-handle-make-process): Fix docstring. --- lisp/net/tramp-sh.el | 10 +++++++--- lisp/net/tramp.el | 3 +-- 2 files changed, 8 insertions(+), 5 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 651444b9e03..df64d13c41f 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2923,15 +2923,19 @@ alternative implementation will be used." ;; until the process is deleted. (when (bufferp stderr) (with-current-buffer stderr - (insert-file-contents-literally remote-tmpstderr)) + ;; There's a mysterious error, see + ;; . + (ignore-errors + (insert-file-contents-literally remote-tmpstderr))) ;; Delete tmpstderr file. (add-function :after (process-sentinel p) (lambda (_proc _msg) (when (file-exists-p remote-tmpstderr) (with-current-buffer stderr - (insert-file-contents-literally - remote-tmpstderr nil nil nil 'replace)) + (ignore-errors + (insert-file-contents-literally + remote-tmpstderr nil nil nil 'replace))) (delete-file remote-tmpstderr))))) ;; Return process. p))) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 8da94ec9d9e..a411aafa875 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3888,8 +3888,7 @@ substitution. SPEC-LIST is a list of char/value pairs used for (or (not (stringp stderr)) (not (tramp-tramp-file-p stderr)))))) (defun tramp-handle-make-process (&rest args) - "An alternative `make-process' implementation for Tramp files. -It does not support `:stderr'." + "An alternative `make-process' implementation for Tramp files." (when args (with-parsed-tramp-file-name (expand-file-name default-directory) nil (let ((default-directory (tramp-compat-temporary-file-directory)) -- cgit v1.2.3 From 4da7b2dfeec82ad0fac987d2628048e85f222258 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Tue, 20 Apr 2021 13:35:26 +0200 Subject: Fix localization problem in Tramp * lisp/net/tramp-sh.el (tramp-get-remote-stat): Use localized quotation characters for check. --- lisp/net/tramp-sh.el | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index df64d13c41f..dde92d87a08 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -5488,15 +5488,15 @@ Nonexistent directories are removed from spec." ;; Check whether stat(1) returns usable syntax. "%s" does not ;; work on older AIX systems. Recent GNU stat versions ;; (8.24?) use shell quoted format for "%N", we check the - ;; boundaries "`" and "'", therefore. See Bug#23422 in - ;; coreutils. Since GNU stat 8.26, environment variable - ;; QUOTING_STYLE is supported. + ;; boundaries "`" and "'" and their localized variants, + ;; therefore. See Bug#23422 in coreutils. Since GNU stat + ;; 8.26, environment variable QUOTING_STYLE is supported. (when result (setq result (concat "env QUOTING_STYLE=locale " result) tmp (tramp-send-command-and-read vec (format "%s -c '(\"%%N\" %%s)' /" result) 'noerror)) (unless (and (listp tmp) (stringp (car tmp)) - (string-match-p "^\\(`/'\\|‘/’\\)$" (car tmp)) + (string-match-p "^[\"`â€˜â€žâ€Â«ă€Œ]/[\"'â€™â€œâ€Â»ă€]$" (car tmp)) (integerp (cadr tmp))) (setq result nil))) result)))) -- cgit v1.2.3 From 0c7f1e2e42d6bf9f95e88c02d4e1ed9cb40693d8 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Wed, 28 Apr 2021 19:29:36 +0200 Subject: Fix gio warning in Tramp * lisp/net/tramp-sh.el (tramp-sh-gio-monitor-process-filter): Improve handling of gio warning. (Bug#48067) --- lisp/net/tramp-sh.el | 38 ++++++++++++++++++-------------------- 1 file changed, 18 insertions(+), 20 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index dde92d87a08..4a3072ee346 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -3730,31 +3730,29 @@ Fall back to normal file name handler if no Tramp handler exists." ;; Determine monitor name. (unless (tramp-connection-property-p proc "gio-file-monitor") - (cond - ;; We have seen this on cygwin gio and on emba. Let's make some assumptions. - ((string-match - "Can't find module 'help' specified in GIO_USE_FILE_MONITOR" string) - (cond - ((getenv "EMACS_EMBA_CI") - (tramp-set-connection-property - proc "gio-file-monitor" 'GInotifyFileMonitor)) - ((eq system-type 'cygwin) - (tramp-set-connection-property - proc "gio-file-monitor" 'GPollFileMonitor)) - (t (tramp-error proc 'file-error "Cannot determine gio monitor")))) - ;; TODO: What happens, if several monitor names are reported? - ((string-match "\ + (tramp-set-connection-property + proc "gio-file-monitor" + (cond + ;; We have seen this on cygwin gio and on emba. Let's make + ;; some assumptions. + ((string-match + "Can't find module 'help' specified in GIO_USE_FILE_MONITOR" string) + (cond + ((getenv "EMACS_EMBA_CI") 'GInotifyFileMonitor) + ((eq system-type 'cygwin) 'GPollFileMonitor) + (t tramp-cache-undefined))) + ;; TODO: What happens, if several monitor names are reported? + ((string-match "\ Supported arguments for GIO_USE_FILE_MONITOR environment variable: \\s-*\\([[:alpha:]]+\\) - 20" string) - (tramp-set-connection-property - proc "gio-file-monitor" (intern - (format "G%sFileMonitor" (capitalize (match-string 1 string)))))) - (t (throw 'doesnt-work nil))) - (setq string (replace-match "" nil nil string))) + (format "G%sFileMonitor" (capitalize (match-string 1 string))))) + (t (throw 'doesnt-work nil)))) + (setq string (substring string (match-end 0)))) ;; Delete empty lines. - (setq string (tramp-compat-string-replace "\n\n" "\n" string)) + (setq string (tramp-compat-string-replace "\n\n" "\n" string) + string (replace-regexp-in-string "^\n" "" string)) (while (string-match (eval-when-compile -- cgit v1.2.3 From a8aa217bff255aa92eae5207c10df8877b0d137a Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Thu, 29 Apr 2021 15:04:51 +0200 Subject: Some Tramp corrections, Bug#48067 * doc/misc/tramp.texi (Frequently Asked Questions): Rephrase GNU ELPA warnings. * lisp/net/tramp-sh.el (tramp-sh-gio-monitor-process-filter): Improve handling of gio warning. (Bug#48067) --- doc/misc/tramp.texi | 10 +++++----- lisp/net/tramp-sh.el | 16 ++++++++++------ 2 files changed, 15 insertions(+), 11 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index e0f648fbd97..ebfc14d9368 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -5100,12 +5100,12 @@ I get an error @samp{tramp-file-name-handler: Invalid function: tramp-compat-with-mutex} @value{tramp} comes with compatibility code for different Emacs -versions. When you see this warning, you don't use the Emacs built-in -version of @value{tramp}. In case you have installed @value{tramp} -from GNU ELPA, see the package README file for instructions how to -recompile it. +versions. When you see such a message (the text might differ), you +don't use the Emacs built-in version of @value{tramp}. In case you +have installed @value{tramp} from GNU ELPA, see the package README +file for instructions how to recompile it. @ifset installchapter -In case you have installed it from its Git repository, @ref{Recompilation}. +@xref{Recompilation}. @end ifset diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 4a3072ee346..b51ba11247f 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -3708,7 +3708,8 @@ Fall back to normal file name handler if no Tramp handler exists." (remote-prefix (with-current-buffer (process-buffer proc) (file-remote-p default-directory))) - (rest-string (process-get proc 'rest-string))) + (rest-string (process-get proc 'rest-string)) + pos) (when rest-string (tramp-message proc 10 "Previous string:\n%s" rest-string)) (tramp-message proc 6 "%S\n%s" proc string) @@ -3737,22 +3738,23 @@ Fall back to normal file name handler if no Tramp handler exists." ;; some assumptions. ((string-match "Can't find module 'help' specified in GIO_USE_FILE_MONITOR" string) + (setq pos (match-end 0)) (cond ((getenv "EMACS_EMBA_CI") 'GInotifyFileMonitor) ((eq system-type 'cygwin) 'GPollFileMonitor) - (t tramp-cache-undefined))) + (t nil))) ;; TODO: What happens, if several monitor names are reported? ((string-match "\ Supported arguments for GIO_USE_FILE_MONITOR environment variable: \\s-*\\([[:alpha:]]+\\) - 20" string) + (setq pos (match-end 0)) (intern (format "G%sFileMonitor" (capitalize (match-string 1 string))))) - (t (throw 'doesnt-work nil)))) - (setq string (substring string (match-end 0)))) + (t (setq pos (length string)) nil))) + (setq string (substring string pos))) ;; Delete empty lines. - (setq string (tramp-compat-string-replace "\n\n" "\n" string) - string (replace-regexp-in-string "^\n" "" string)) + (setq string (tramp-compat-string-replace "\n\n" "\n" string)) (while (string-match (eval-when-compile @@ -3783,6 +3785,8 @@ Supported arguments for GIO_USE_FILE_MONITOR environment variable: `(file-notify ,object file-notify-callback)))))) ;; Save rest of the string. + (while (string-match "^\n" string) + (setq string (replace-match "" nil nil string))) (when (zerop (length string)) (setq string nil)) (when string (tramp-message proc 10 "Rest string:\n%s" string)) (process-put proc 'rest-string string))) -- cgit v1.2.3 From b6f5da3240170fb9750a3304e4b8fa04fe7f2268 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Thu, 6 May 2021 17:15:30 +0200 Subject: In Tramp, use scp "-T" argument if available * lisp/net/tramp-sh.el (tramp-scp-strict-file-name-checking): New defvar. (tramp-scp-strict-file-name-checking): New defun. (tramp-do-copy-or-rename-file-out-of-band): Use it. (tramp-methods) : Use "%x". (tramp-make-copy-program-file-name): Use local quoting. (tramp-sh-handle-make-process): Don't call `tramp-maybe-open-connection', this happens implicitly by `tramp-send-command'. * lisp/net/tramp.el (tramp-methods): Adapt docstring. * test/lisp/net/tramp-tests.el (tramp-test40-special-characters) (tramp-test40-special-characters-with-stat) (tramp-test40-special-characters-with-perl) (tramp-test40-special-characters-with-ls): Don't skip for `tramp--test-windows-nt-and-scp-p'. --- lisp/net/tramp-sh.el | 57 ++++++++++++++++++++++++++++++++++---------- lisp/net/tramp.el | 2 ++ test/lisp/net/tramp-tests.el | 8 +++---- 3 files changed, 50 insertions(+), 17 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index b51ba11247f..57be9ecf006 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -125,6 +125,15 @@ depends on the installed local ssh version. The string is used in `tramp-methods'.") +(defvar tramp-scp-strict-file-name-checking nil + "Which scp strict file name checking argument to use. + +It is the string \"-T\" if supported by the local scp (since +release 8.0), otherwise the string \"\". If it is nil, it will +be auto-detected by Tramp. + +The string is used in `tramp-methods'.") + ;; Initialize `tramp-methods' with the supported methods. ;;;###tramp-autoload (tramp--with-startup @@ -160,8 +169,8 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-copy-program "scp") - (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") - ("-r") ("%c"))) + (tramp-copy-args (("-P" "%p") ("-p" "%k") + ("%x") ("-q") ("-r") ("%c"))) (tramp-copy-keep-date t) (tramp-copy-recursive t))) (add-to-list 'tramp-methods @@ -177,7 +186,7 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-args ("-c")) (tramp-copy-program "scp") (tramp-copy-args (("-P" "%p") ("-p" "%k") - ("-q") ("-r") ("%c"))) + ("%x") ("-q") ("-r") ("%c"))) (tramp-copy-keep-date t) (tramp-copy-recursive t))) (add-to-list 'tramp-methods @@ -2279,7 +2288,8 @@ The method used must be an out-of-band method." spec (list ?h (or host "") ?u (or user "") ?p (or port "") ?r listener ?c options ?k (if keep-date " " "") - ?n (concat "2>" (tramp-get-remote-null-device v))) + ?n (concat "2>" (tramp-get-remote-null-device v)) + ?x (tramp-scp-strict-file-name-checking v)) copy-program (tramp-get-method-parameter v 'tramp-copy-program) copy-keep-date (tramp-get-method-parameter v 'tramp-copy-keep-date) @@ -2867,14 +2877,11 @@ alternative implementation will be used." (if (symbolp coding) coding (cdr coding)))) (clear-visited-file-modtime) (narrow-to-region (point-max) (point-max)) - ;; We call `tramp-maybe-open-connection', in - ;; order to cleanup the prompt afterwards. (catch 'suppress - (tramp-maybe-open-connection v) - (setq p (tramp-get-connection-process v)) ;; Set the pid of the remote shell. This is ;; needed when sending signals remotely. (let ((pid (tramp-send-command-and-read v "echo $$"))) + (setq p (tramp-get-connection-process v)) (process-put p 'remote-pid pid) (tramp-set-connection-property p "remote-pid" pid)) ;; `tramp-maybe-open-connection' and @@ -4737,6 +4744,31 @@ Goes through the list `tramp-inline-compress-commands'." " -o ControlPersist=no"))))))))) tramp-ssh-controlmaster-options))) +(defun tramp-scp-strict-file-name-checking (vec) + "Return the strict file name checking argument of the local scp." + (cond + ;; No options to be computed. + ((null (assoc "%x" (tramp-get-method-parameter vec 'tramp-copy-args))) + "") + + ;; There is already a value to be used. + ((stringp tramp-scp-strict-file-name-checking) + tramp-scp-strict-file-name-checking) + + ;; Determine the options. + (t (setq tramp-scp-strict-file-name-checking "") + (let ((case-fold-search t)) + (ignore-errors + (when (executable-find "scp") + (with-tramp-progress-reporter + vec 4 "Computing strict file name argument" + (with-temp-buffer + (tramp-call-process vec "scp" nil t nil "-T") + (goto-char (point-min)) + (unless (search-forward-regexp "unknown option -- T" nil t) + (setq tramp-scp-strict-file-name-checking "-T"))))))) + tramp-scp-strict-file-name-checking))) + (defun tramp-timeout-session (vec) "Close the connection VEC after a session timeout. If there is just some editing, retry it after 5 seconds." @@ -5229,12 +5261,11 @@ Return ATTR." (directory-file-name (tramp-file-name-unquote-localname vec)))) (when (string-match-p tramp-ipv6-regexp host) (setq host (format "[%s]" host))) - ;; This does not work yet for MS Windows scp, if there are - ;; characters to be quoted. Win32 OpenSSH 7.9 is said to support - ;; this, see - ;; + ;; This does not work for MS Windows scp, if there are characters + ;; to be quoted. OpenSSH 8 supports disabling of strict file name + ;; checking in scp, we use it when available. (unless (string-match-p "ftp$" method) - (setq localname (tramp-shell-quote-argument localname))) + (setq localname (shell-quote-argument localname))) (cond ((tramp-get-method-parameter vec 'tramp-remote-copy-program) localname) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 015f458a63c..741ea05ceaf 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -252,6 +252,8 @@ pair of the form (KEY VALUE). The following KEYs are defined: - \"%c\" adds additional `tramp-ssh-controlmaster-options' options for the first hop. - \"%n\" expands to \"2>/dev/null\". + - \"%x\" is replaced by the `tramp-scp-strict-file-name-checking' + argument if it is supported. The existence of `tramp-login-args', combined with the absence of `tramp-copy-args', is an indication that the diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 1eb0d0ec619..3a199469d6b 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -6114,7 +6114,7 @@ This requires restrictions of file name syntax." "Check special characters in file names." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-scp-p))) +; (skip-unless (not (tramp--test-windows-nt-and-scp-p))) (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) (tramp--test-special-characters)) @@ -6126,7 +6126,7 @@ Use the `stat' command." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-scp-p))) +; (skip-unless (not (tramp--test-windows-nt-and-scp-p))) ;; We cannot use `tramp-test-vec', because this fails during compilation. (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-stat v))) @@ -6145,7 +6145,7 @@ Use the `perl' command." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-scp-p))) +; (skip-unless (not (tramp--test-windows-nt-and-scp-p))) ;; We cannot use `tramp-test-vec', because this fails during compilation. (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-perl v))) @@ -6167,7 +6167,7 @@ Use the `ls' command." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-scp-p))) +; (skip-unless (not (tramp--test-windows-nt-and-scp-p))) (let ((tramp-connection-properties (append -- cgit v1.2.3 From f50577ea07fd85a1798cc2d41251ab1418fd802f Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Fri, 7 May 2021 14:31:17 +0200 Subject: Fix some annoyances wrt file-name-non-special * lisp/files.el (file-name-non-special): Do not expand `file-truename'. * lisp/net/tramp-sh.el (tramp-do-copy-or-rename-file-out-of-band): Use local `default-directory' for `start-process'. --- lisp/files.el | 5 ++++- lisp/net/tramp-sh.el | 11 ++++++----- 2 files changed, 10 insertions(+), 6 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/files.el b/lisp/files.el index 27074beffc1..93a0e07aba0 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -7559,7 +7559,10 @@ only these files will be asked to be saved." (setq file-arg-indices (cdr file-arg-indices)))) (pcase method ('identity (car arguments)) - ('add (file-name-quote (apply operation arguments) t)) + ('add + ;; This is `file-truename'. We don't want file name handlers + ;; to expand this. + (file-name-quote (let (tramp-mode) (apply operation arguments)) t)) ('buffer-file-name (let ((buffer-file-name (file-name-unquote buffer-file-name t))) (apply operation arguments))) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 57be9ecf006..3ce74a2cf1a 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2371,11 +2371,12 @@ The method used must be an out-of-band method." ;; can be handled. We don't set a timeout, because ;; the copying of large files can last longer than 60 ;; secs. - p (apply - #'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - copy-program copy-args)) + p (let ((default-directory (tramp-compat-temporary-file-directory))) + (apply + #'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + copy-program copy-args))) (tramp-message orig-vec 6 "%s" (string-join (process-command p) " ")) (process-put p 'vector orig-vec) (process-put p 'adjust-window-size-function #'ignore) -- cgit v1.2.3 From 9457d4f20f1f3da8450924cfe1f776fdd04261bb Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Fri, 7 May 2021 17:25:49 +0200 Subject: Tramp: Fix file name quoting on MS Windows * lisp/net/tramp-sh.el (tramp-make-copy-program-file-name): Use `tramp-unquote-shell-quote-argument'. * lisp/net/tramp.el (tramp-unquote-shell-quote-argument): Adapt for MS Windows. * test/lisp/net/tramp-tests.el (tramp--test-special-characters): Adapt for MS Windows. --- lisp/net/tramp-sh.el | 2 +- lisp/net/tramp.el | 8 ++++++-- test/lisp/net/tramp-tests.el | 15 +++++++-------- 3 files changed, 14 insertions(+), 11 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 3ce74a2cf1a..60090d31b88 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -5266,7 +5266,7 @@ Return ATTR." ;; to be quoted. OpenSSH 8 supports disabling of strict file name ;; checking in scp, we use it when available. (unless (string-match-p "ftp$" method) - (setq localname (shell-quote-argument localname))) + (setq localname (tramp-unquote-shell-quote-argument localname))) (cond ((tramp-get-method-parameter vec 'tramp-remote-copy-program) localname) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 9fec1514221..5d62a1fb3d1 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -5476,8 +5476,12 @@ T1 and T2 are time values (as returned by `current-time' for example)." "Remove quotation prefix \"/:\" from string S, and quote it then for shell. Suppress `shell-file-name'. This is needed on w32 systems, which would use a wrong quoting for local file names. See `w32-shell-name'." - (let (shell-file-name) - (shell-quote-argument (tramp-compat-file-name-unquote s)))) + (if (eq system-type 'windows-nt) + (let ((result (tramp-compat-file-name-unquote s))) + (setq result (tramp-compat-string-replace "\"" "\"\"" result)) + (concat "\"" result "\"")) + (let (shell-file-name) + (shell-quote-argument (tramp-compat-file-name-unquote s))))) ;; Currently (as of Emacs 20.5), the function `shell-quote-argument' ;; does not deal well with newline characters. Newline is replaced by diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 0f6f3b79800..03915d7a3fc 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -5882,6 +5882,7 @@ This requires restrictions of file name syntax." (make-directory tmp-name2) (dolist (elt files) + ;(tramp--test-message "%s" elt) (let* ((file1 (expand-file-name elt tmp-name1)) (file2 (expand-file-name elt tmp-name2)) (file3 (expand-file-name (concat elt "foo") tmp-name1))) @@ -6071,7 +6072,8 @@ This requires restrictions of file name syntax." "\tfoo bar baz\t") (t " foo\tbar baz\t")) "@foo@bar@baz@" - "$foo$bar$$baz$" + (unless (tramp--test-windows-nt-and-scp-p) + "$foo$bar$$baz$") "-foo-bar-baz-" "%foo%bar%baz%" "&foo&bar&baz&" @@ -6087,9 +6089,10 @@ This requires restrictions of file name syntax." "'foo'bar'baz'" "'foo\"bar'baz\"") "#foo~bar#baz~" - (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) - "!foo!bar!baz!" - "!foo|bar!baz|") + (unless (tramp--test-windows-nt-and-scp-p) + (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) + "!foo!bar!baz!" + "!foo|bar!baz|")) (if (or (tramp--test-gvfs-p) (tramp--test-rclone-p) (tramp--test-windows-nt-or-smb-p)) @@ -6110,7 +6113,6 @@ This requires restrictions of file name syntax." "Check special characters in file names." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-rsync-p))) -; (skip-unless (not (tramp--test-windows-nt-and-scp-p))) (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) (tramp--test-special-characters)) @@ -6122,7 +6124,6 @@ Use the `stat' command." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) -; (skip-unless (not (tramp--test-windows-nt-and-scp-p))) ;; We cannot use `tramp-test-vec', because this fails during compilation. (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-stat v))) @@ -6141,7 +6142,6 @@ Use the `perl' command." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) -; (skip-unless (not (tramp--test-windows-nt-and-scp-p))) ;; We cannot use `tramp-test-vec', because this fails during compilation. (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-perl v))) @@ -6163,7 +6163,6 @@ Use the `ls' command." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) -; (skip-unless (not (tramp--test-windows-nt-and-scp-p))) (let ((tramp-connection-properties (append -- cgit v1.2.3 From 4f510f63a8fc3483eeac7887cb69ddfa6de9b5a6 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sun, 16 May 2021 12:08:09 +0200 Subject: Fix handling of stderr buffer in Tramp's make-process (Bug#47861) * lisp/net/tramp-sh.el (tramp-sh-handle-make-process): Reimplement stderr buffer handling. (Bug#47861) (tramp-maybe-open-connection): Improve traces. * test/lisp/net/tramp-tests.el (tramp-test30-make-process): Rework for stderr buffer. --- lisp/net/tramp-sh.el | 79 +++++++++++++++++++++----------------------- test/lisp/net/tramp-tests.el | 64 ++++++++++++++++++----------------- 2 files changed, 71 insertions(+), 72 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 60090d31b88..f24d0effe71 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2723,13 +2723,12 @@ the result will be a local, non-Tramp, file name." ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once ;; connection has been setup. -;; The complete STDERR buffer is available only when the process has -;; terminated. (defun tramp-sh-handle-make-process (&rest args) "Like `make-process' for Tramp files. -STDERR can also be a file name. If method parameter `tramp-direct-async' -and connection property \"direct-async-process\" are non-nil, an -alternative implementation will be used." +STDERR can also be a remote file name. If method parameter +`tramp-direct-async' and connection property +\"direct-async-process\" are non-nil, an alternative +implementation will be used." (if (tramp-direct-async-process-p args) (apply #'tramp-handle-make-process args) (when args @@ -2763,7 +2762,7 @@ alternative implementation will be used." (signal 'wrong-type-argument (list #'functionp sentinel))) (unless (or (null stderr) (bufferp stderr) (stringp stderr)) (signal 'wrong-type-argument (list #'bufferp stderr))) - (when (and (stringp stderr) (tramp-tramp-file-p stderr) + (when (and (stringp stderr) (not (tramp-equal-remote default-directory stderr))) (signal 'file-error (list "Wrong stderr" stderr))) @@ -2775,9 +2774,9 @@ alternative implementation will be used." ;; STDERR can also be a file name. (tmpstderr (and stderr - (if (and (stringp stderr) (tramp-tramp-file-p stderr)) - (tramp-unquote-file-local-name stderr) - (tramp-make-tramp-temp-file v)))) + (tramp-unquote-file-local-name + (if (stringp stderr) + stderr (tramp-make-tramp-temp-name v))))) (remote-tmpstderr (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) (program (car command)) @@ -2786,7 +2785,8 @@ alternative implementation will be used." ;; "-c", it might be that the arguments exceed the ;; command line length. Therefore, we modify the ;; command. - (heredoc (and (stringp program) + (heredoc (and (not (bufferp stderr)) + (stringp program) (string-match-p "sh$" program) (= (length args) 2) (string-equal "-c" (car args)) @@ -2850,6 +2850,23 @@ alternative implementation will be used." tramp-current-connection p) + ;; Handle error buffer. + (when (bufferp stderr) + (with-current-buffer stderr + (setq buffer-read-only nil)) + ;; Create named pipe. + (tramp-send-command v (format "mknod %s p" tmpstderr)) + ;; Create stderr process. + (make-process + :name (buffer-name stderr) + :buffer stderr + :command `("cat" ,tmpstderr) + :coding coding + :noquery t + :filter nil + :sentinel #'ignore + :file-handler t)) + (while (get-process name1) ;; NAME must be unique as process name. (setq i (1+ i) @@ -2912,38 +2929,16 @@ alternative implementation will be used." (ignore-errors (set-process-query-on-exit-flag p (null noquery)) (set-marker (process-mark p) (point))) - ;; We must flush them here already; otherwise - ;; `rename-file', `delete-file' or - ;; `insert-file-contents' will fail. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") - ;; Copy tmpstderr file. - (when (and (stringp stderr) - (not (tramp-tramp-file-p stderr))) - (add-function - :after (process-sentinel p) - (lambda (_proc _msg) - (rename-file remote-tmpstderr stderr)))) - ;; Provide error buffer. This shows only - ;; initial error messages; messages arriving - ;; later on will be inserted when the process - ;; is deleted. The temporary file will exist - ;; until the process is deleted. + ;; Kill stderr process delete and named pipe. (when (bufferp stderr) - (with-current-buffer stderr - ;; There's a mysterious error, see - ;; . - (ignore-errors - (insert-file-contents-literally remote-tmpstderr))) - ;; Delete tmpstderr file. (add-function :after (process-sentinel p) (lambda (_proc _msg) - (when (file-exists-p remote-tmpstderr) - (with-current-buffer stderr - (ignore-errors - (insert-file-contents-literally - remote-tmpstderr nil nil nil 'replace))) + (ignore-errors + (while (accept-process-output + (get-buffer-process stderr) 0 nil t)) + (delete-process (get-buffer-process stderr))) + (ignore-errors (delete-file remote-tmpstderr))))) ;; Return process. p))) @@ -4834,10 +4829,12 @@ connection if a previous connection has died for some reason." (with-tramp-progress-reporter vec 3 (if (zerop (length (tramp-file-name-user vec))) - (format "Opening connection for %s using %s" + (format "Opening connection %s for %s using %s" + process-name (tramp-file-name-host vec) (tramp-file-name-method vec)) - (format "Opening connection for %s@%s using %s" + (format "Opening connection %s for %s@%s using %s" + process-name (tramp-file-name-user vec) (tramp-file-name-host vec) (tramp-file-name-method vec))) @@ -5937,8 +5934,6 @@ function cell is returned to be applied on a buffer." ;; session could be reused after a connection loss. Use dtach, or ;; screen, or tmux, or mosh. ;; -;; * Implement `:stderr' of `make-process' as pipe process. - ;; * One interesting solution (with other applications as well) would ;; be to stipulate, as a directory or connection-local variable, an ;; additional rc file on the remote machine that is sourced every diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index a045b9c62f7..5e4626ab41a 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -4581,8 +4581,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) - (tmp-name1 (tramp--test-make-temp-name nil quoted)) - (tmp-name2 (tramp--test-make-temp-name 'local quoted)) + (tmp-name (tramp--test-make-temp-name nil quoted)) kill-buffer-query-functions proc) (with-no-warnings (should-not (make-process))) @@ -4610,13 +4609,13 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Simple process using a file. (unwind-protect (with-temp-buffer - (write-region "foo" nil tmp-name1) - (should (file-exists-p tmp-name1)) + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) (setq proc (with-no-warnings (make-process :name "test2" :buffer (current-buffer) - :command `("cat" ,(file-name-nondirectory tmp-name1)) + :command `("cat" ,(file-name-nondirectory tmp-name)) :file-handler t))) (should (processp proc)) ;; Read output. @@ -4628,7 +4627,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Cleanup. (ignore-errors (delete-process proc) - (delete-file tmp-name1))) + (delete-file tmp-name))) ;; Process filter. (unwind-protect @@ -4692,11 +4691,17 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." :stderr stderr :file-handler t))) (should (processp proc)) - ;; Read stderr. + ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) (while (accept-process-output proc 0 nil t))) - (delete-process proc) + ;; Read stderr. (with-current-buffer stderr + (with-timeout (10 (tramp--test-timeout-handler)) + (while (not (string-match-p + "No such file or directory" (buffer-string))) + (while (accept-process-output + (get-buffer-process stderr) 0 nil t)))) + (delete-process proc) (should (string-match-p "cat:.* No such file or directory" (buffer-string))))) @@ -4707,30 +4712,29 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Process with stderr file. (unless (tramp-direct-async-process-p) - (dolist (tmpfile `(,tmp-name1 ,tmp-name2)) - (unwind-protect + (unwind-protect + (with-temp-buffer + (setq proc + (with-no-warnings + (make-process + :name "test6" :buffer (current-buffer) + :command '("cat" "/does-not-exist") + :stderr tmp-name + :file-handler t))) + (should (processp proc)) + ;; Read stderr. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (accept-process-output proc nil nil t))) + (delete-process proc) (with-temp-buffer - (setq proc - (with-no-warnings - (make-process - :name "test6" :buffer (current-buffer) - :command '("cat" "/does-not-exist") - :stderr tmpfile - :file-handler t))) - (should (processp proc)) - ;; Read stderr. - (with-timeout (10 (tramp--test-timeout-handler)) - (while (accept-process-output proc nil nil t))) - (delete-process proc) - (with-temp-buffer - (insert-file-contents tmpfile) - (should - (string-match-p - "cat:.* No such file or directory" (buffer-string))))) + (insert-file-contents tmp-name) + (should + (string-match-p + "cat:.* No such file or directory" (buffer-string))))) - ;; Cleanup. - (ignore-errors (delete-process proc)) - (ignore-errors (delete-file tmpfile)))))))) + ;; Cleanup. + (ignore-errors (delete-process proc)) + (ignore-errors (delete-file tmp-name))))))) (tramp--test--deftest-direct-async-process tramp-test30-make-process "Check direct async `make-process'.") -- cgit v1.2.3 From 4db69b32b835a833168982b0f11a43d7f62ba8b2 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 22 May 2021 17:51:07 +0200 Subject: Fix bug#48476 * lisp/net/tramp-archive.el (tramp-archive-autoload-file-name-handler): Add implementation. * lisp/net/tramp-integration.el (tramp-rename-files) (tramp-rename-these-files): Declare them. * lisp/net/tramp.el (tramp-autoload-file-name-handler): Load tramp-archive.el if needed. (Bug#48476) * test/lisp/net/tramp-archive-tests.el (tramp-archive-test45-auto-load): Extend test. Use #' syntax for function symbols. --- lisp/net/tramp-archive.el | 8 +++++-- lisp/net/tramp-cache.el | 3 +-- lisp/net/tramp-gvfs.el | 2 +- lisp/net/tramp-integration.el | 16 +++++++------ lisp/net/tramp-sh.el | 4 ++-- lisp/net/tramp-sudoedit.el | 2 +- lisp/net/tramp.el | 8 ++++--- test/lisp/net/tramp-archive-tests.el | 46 +++++++++++++++++++++--------------- 8 files changed, 52 insertions(+), 37 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 61c40ffdea3..a37009402cf 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -345,8 +345,12 @@ arguments to pass to the OPERATION." (tramp-archive-run-real-handler operation args))))))) ;;;###autoload -(defalias - 'tramp-archive-autoload-file-name-handler #'tramp-autoload-file-name-handler) +(progn (defun tramp-archive-autoload-file-name-handler (operation &rest args) + "Load Tramp archive file name handler, and perform OPERATION." + (if tramp-archive-enabled + (let ((tramp-archive-autoload t)) + tramp-archive-autoload ; Silence byte compiler. + (apply #'tramp-autoload-file-name-handler operation args))))) ;;;###autoload (progn (defun tramp-register-archive-file-name-handler () diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 2fcb7b11e8d..fdde7fbe44e 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -237,8 +237,7 @@ Return VALUE." ;;;###tramp-autoload (defun tramp-flush-file-properties (key file) "Remove all properties of FILE in the cache context of KEY." - (let* ((file (tramp-run-real-handler - #'directory-file-name (list file))) + (let* ((file (tramp-run-real-handler #'directory-file-name (list file))) (truename (tramp-get-file-property key file "file-truename" nil))) ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index c4ec1121da2..f1d24dc0c41 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -1089,7 +1089,7 @@ file names." 'copy filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) (tramp-run-real-handler - 'copy-file + #'copy-file (list filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes)))) diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index 2931b4f0cc8..17264193fd6 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -42,6 +42,8 @@ (declare-function tramp-dissect-file-name "tramp") (declare-function tramp-file-name-equal-p "tramp") (declare-function tramp-tramp-file-p "tramp") +(declare-function tramp-rename-files "tramp-cmds") +(declare-function tramp-rename-these-files "tramp-cmds") (defvar eshell-path-env) (defvar ido-read-file-name-non-ido) (defvar info-lookup-alist) @@ -184,14 +186,14 @@ NAME must be equal to `tramp-current-connection'." ;;; Integration of ido.el: (with-eval-after-load 'ido - (add-to-list 'ido-read-file-name-non-ido 'tramp-rename-files) - (add-to-list 'ido-read-file-name-non-ido 'tramp-these-rename-files) + (add-to-list 'ido-read-file-name-non-ido #'tramp-rename-files) + (add-to-list 'ido-read-file-name-non-ido #'tramp-rename-these-files) (add-hook 'tramp-integration-unload-hook (lambda () (setq ido-read-file-name-non-ido - (delq 'tramp-these-rename-files ido-read-file-name-non-ido) + (delq #'tramp-rename-these-files ido-read-file-name-non-ido) ido-read-file-name-non-ido - (delq 'tramp-rename-files ido-read-file-name-non-ido))))) + (delq #'tramp-rename-files ido-read-file-name-non-ido))))) ;;; Integration of ivy.el: @@ -199,17 +201,17 @@ NAME must be equal to `tramp-current-connection'." (add-to-list 'ivy-completing-read-handlers-alist '(tramp-rename-files . completing-read-default)) (add-to-list 'ivy-completing-read-handlers-alist - '(tramp-these-rename-files . completing-read-default)) + '(tramp-rename-these-files . completing-read-default)) (add-hook 'tramp-integration-unload-hook (lambda () (setq ivy-completing-read-handlers-alist (delete - (assq 'tramp-these-rename-files ivy-completing-read-handlers-alist) + (assq #'tramp-rename-these-files ivy-completing-read-handlers-alist) ivy-completing-read-handlers-alist) ivy-completing-read-handlers-alist (delete - (assq 'tramp-rename-files ivy-completing-read-handlers-alist) + (assq #'tramp-rename-files ivy-completing-read-handlers-alist) ivy-completing-read-handlers-alist))))) ;;; Integration of info-look.el: diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index f24d0effe71..29ed944b8b0 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1843,7 +1843,7 @@ ID-FORMAT valid values are `string' and `integer'." 'copy filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) (tramp-run-real-handler - 'copy-file + #'copy-file (list filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes)))) @@ -1884,7 +1884,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; We must do it file-wise. (tramp-run-real-handler - 'copy-directory + #'copy-directory (list dirname newname keep-date parents copy-contents))) ;; When newname did exist, we have wrong cached values. diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 66737e61da7..d6417094bae 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -650,7 +650,7 @@ component is used as the target of the symlink." 'rename filename newname ok-if-already-exists 'keep-date 'preserve-uid-gid) (tramp-run-real-handler - 'rename-file (list filename newname ok-if-already-exists)))) + #'rename-file (list filename newname ok-if-already-exists)))) (defun tramp-sudoedit-handle-set-file-acl (filename acl-string) "Like `set-file-acl' for Tramp files." diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 62df2890cb1..4fd7a322d4b 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2631,6 +2631,8 @@ Falls back to normal file name handler if no Tramp file name handler exists." ;; might be an older, incompatible version active. We try to ;; overload this. (let ((default-directory temporary-file-directory)) + (when (bound-and-true-p tramp-archive-autoload) + (load "tramp-archive" 'noerror 'nomessage)) (load "tramp" 'noerror 'nomessage))) (apply operation args))) @@ -2642,7 +2644,7 @@ Falls back to normal file name handler if no Tramp file name handler exists." "Add Tramp file name handlers to `file-name-handler-alist' during autoload." (add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp - 'tramp-autoload-file-name-handler)) + #'tramp-autoload-file-name-handler)) (put #'tramp-autoload-file-name-handler 'safe-magic t))) ;;;###autoload (tramp-register-autoload-file-name-handlers) @@ -2854,7 +2856,7 @@ not in completion mode." result1 (ignore-errors (tramp-run-real-handler - 'file-name-all-completions (list filename directory)))))) + #'file-name-all-completions (list filename directory)))))) ;; Method, host name and user name completion for a file. (defun tramp-completion-handle-file-name-completion @@ -3275,7 +3277,7 @@ User is always nil." (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) ;; We must do it file-wise. (tramp-run-real-handler - 'copy-directory + #'copy-directory (list directory newname keep-date parents copy-contents))) (defun tramp-handle-directory-file-name (directory) diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 6a6b56f4a1d..773bc8f4594 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -887,27 +887,35 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." ;; tramp-archive is neither loaded at Emacs startup, nor when ;; loading a file like "/mock::foo" (which loads Tramp). - (let ((default-directory (expand-file-name temporary-file-directory)) - (code + (let ((code "(progn \ - (message \"tramp-archive loaded: %%s %%s\" \ - (featurep 'tramp) (featurep 'tramp-archive)) \ + (message \"tramp-archive loaded: %%s\" \ + (featurep 'tramp-archive)) \ (file-attributes %S \"/\") \ - (message \"tramp-archive loaded: %%s %%s\" \ - (featurep 'tramp) (featurep 'tramp-archive)))")) - (dolist (file `("/mock::foo" ,(concat tramp-archive-test-archive "foo"))) - (should - (string-match - (format - "tramp-archive loaded: nil nil[[:ascii:]]+tramp-archive loaded: t %s" - (tramp-archive-file-name-p file)) - (shell-command-to-string - (format - "%s -batch -Q -L %s --eval %s" - (shell-quote-argument - (expand-file-name invocation-name invocation-directory)) - (mapconcat #'shell-quote-argument load-path " -L ") - (shell-quote-argument (format code file))))))))) + (message \"tramp-archive loaded: %%s\" \ + (featurep 'tramp-archive)))")) + (dolist (default-directory + `(,temporary-file-directory + ;; Starting Emacs in a directory which has + ;; `tramp-archive-file-name-regexp' syntax is + ;; supported only with Emacs > 27.2 (sigh!). + ;; (Bug#48476) + ,(file-name-as-directory tramp-archive-test-directory))) + (dolist (file `("/mock::foo" ,(concat tramp-archive-test-archive "foo"))) + (should + (string-match + (format + "tramp-archive loaded: %s[[:ascii:]]+tramp-archive loaded: %s" + (tramp-archive-file-name-p default-directory) + (or (tramp-archive-file-name-p default-directory) + (tramp-archive-file-name-p file))) + (shell-command-to-string + (format + "%s -batch -Q -L %s --eval %s" + (shell-quote-argument + (expand-file-name invocation-name invocation-directory)) + (mapconcat #'shell-quote-argument load-path " -L ") + (shell-quote-argument (format code file)))))))))) (ert-deftest tramp-archive-test45-delay-load () "Check that `tramp-archive' is loaded lazily, only when needed." -- cgit v1.2.3 From 6536112bdce592eed9f3d71022aafbe6be44da45 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Mon, 14 Jun 2021 11:25:13 +0200 Subject: Handle sensitive auto-save or backup remote files (Bug#45245) * doc/misc/tramp.texi (Auto-save and Backup): Describe tramp-allow-unsafe-temporary-files. (Ad-hoc multi-hops): Use proper format. * etc/NEWS: Mention confirmation for writing sensitive auto-save or backup remote files to the local temporary directory.. * lisp/net/tramp-cache.el (tramp-dump-connection-properties): Strengthen test. * lisp/net/tramp.el (tramp-allow-unsafe-temporary-files): New defcustom. (tramp-handle-find-backup-file-name) (tramp-handle-make-auto-save-file-name): Don't expose sensible auto-save or backup files on local temporary directory. (Bug#45245) * test/lisp/net/tramp-tests.el (tramp--test-always): New defalias. (tramp-test10-write-region, tramp-test21-file-links) (tramp--test--deftest-direct-async-process): Use it. (tramp-test37-make-auto-save-file-name) (tramp-test38-find-backup-file-name): Extend tests. --- doc/misc/tramp.texi | 17 ++++--- etc/NEWS | 7 ++- lisp/net/tramp-cache.el | 7 +-- lisp/net/tramp-sh.el | 3 +- lisp/net/tramp.el | 103 +++++++++++++++++++++++++++++-------------- test/lisp/net/tramp-tests.el | 85 +++++++++++++++++++++++++++++++---- 6 files changed, 169 insertions(+), 53 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index e5a0bb9a8b6..6ef9459077e 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -1261,7 +1261,7 @@ uses @file{@trampfn{mtp,,}} as the default name. As the name indicates, the method @option{nextcloud} allows you to access OwnCloud or NextCloud hosted files and directories. Like the @option{gdrive} method, your credentials must be populated in your -@command{Online Accounts} application outside Emacs. The method +@command{Online Accounts} application outside Emacs. The method supports port numbers. @item @option{sftp} @@ -2842,6 +2842,13 @@ auto-saved files to the same directory as the original file. Alternatively, set the user option @code{tramp-auto-save-directory} to direct all auto saves to that location. +@vindex tramp-allow-unsafe-temporary-files +Per default, @value{tramp} asks for confirmation if a +@samp{root}-owned backup or auto-save remote file has to be written to +your local temporary directory. If you want to suppress this +confirmation question, set user option +@code{tramp-allow-unsafe-temporary-files} to @code{t}. + @node Keeping files encrypted @section Protect remote files by encryption @@ -3309,12 +3316,12 @@ For ad-hoc definitions to be saved automatically in Ad-hoc proxies can take patterns @code{%h} or @code{%u} like in @code{tramp-default-proxies-alist}. The following file name expands -to user @code{root} on host @code{remotehost}, starting with an -@option{ssh} session on host @code{remotehost}: +to user @samp{root} on host @samp{remotehost}, starting with an +@option{ssh} session on host @samp{remotehost}: @samp{@value{prefix}ssh@value{postfixhop}%h|su@value{postfixhop}remotehost@value{postfix}}. On the other hand, if a trailing hop does not specify a host name, -the host name of the previous hop is reused. Therefore, the following +the host name of the previous hop is reused. Therefore, the following file name is equivalent to the previous example: @samp{@value{prefix}ssh@value{postfixhop}remotehost|su@value{postfixhop}@value{postfix}}. @@ -5294,7 +5301,7 @@ attributes cache in its process sentinel with this code: @end lisp Since @value{tramp} traverses subdirectories starting with the -root-directory, it is most likely sufficient to make the +root directory, it is most likely sufficient to make the @code{default-directory} of the process buffer as the root directory. diff --git a/etc/NEWS b/etc/NEWS index 4fe95ddc262..367cd5972ac 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -605,7 +605,7 @@ These options include 'windmove-default-keybindings', ** Windows +++ -*** New option 'delete-window-choose-selected'. +*** New user option 'delete-window-choose-selected'. This allows to choose a frame's selected window after deleting the previously selected one. @@ -1403,6 +1403,11 @@ When non-nil, this user option instructs Tramp to mirror the debug buffer to a file under the "/tmp/" directory. This is useful, if (in rare cases) Tramp blocks Emacs, and we need further debug information. ++++ +*** Writing sensitive auto-save or backup files to the local temporary +directory must be confirmed. In order to suppress this confirmation, +set user option 'tramp-allow-unsafe-temporary-files' to t. + ** Tempo --- diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index fdde7fbe44e..a41620ab9f7 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -70,7 +70,8 @@ ;; process key retrieved by `tramp-get-process' (the main connection ;; process). Other processes could reuse these properties, avoiding ;; recomputation when a new asynchronous process is created by -;; `make-process'. Examples are "remote-path" or "device" (tramp-adb.el). +;; `make-process'. Examples are "remote-path", +;; "unsafe-temporary-file" or "device" (tramp-adb.el). ;;; Code: @@ -470,11 +471,11 @@ used to cache connection properties of the local machine." ;; don't save either, because all other properties might ;; depend on the login name, and we want to give the ;; possibility to use another login name later on. Key - ;; "started" exists for the "ftp" method only, which must be + ;; "started" exists for the "ftp" method only, which must not ;; be kept persistent. (maphash (lambda (key value) - (if (and (tramp-file-name-p key) value + (if (and (tramp-file-name-p key) (hash-table-p value) (not (string-equal (tramp-file-name-method key) tramp-archive-method)) (not (tramp-file-name-localname key)) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 29ed944b8b0..b613ad3f8e7 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -5296,8 +5296,7 @@ Nonexistent directories are removed from spec." ;; cache the result for the session only. Otherwise, the ;; result is cached persistently. (if (memq 'tramp-own-remote-path tramp-remote-path) - (tramp-get-process vec) - vec) + (tramp-get-process vec) vec) "remote-path" (let* ((remote-path (copy-tree tramp-remote-path)) (elt1 (memq 'tramp-default-remote-path remote-path)) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 838464e88b2..5284981961a 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3627,6 +3627,11 @@ User is always nil." (and (file-directory-p (file-name-directory filename)) (file-writable-p (file-name-directory filename))))))) +(defcustom tramp-allow-unsafe-temporary-files nil + "Whether root-owned auto-save or backup files can be written to \"/tmp\"." + :version "28.1" + :type 'boolean) + (defun tramp-handle-find-backup-file-name (filename) "Like `find-backup-file-name' for Tramp files." (with-parsed-tramp-file-name filename nil @@ -3642,8 +3647,25 @@ User is always nil." (tramp-make-tramp-file-name v (cdr x)) (cdr x)))) tramp-backup-directory-alist) - backup-directory-alist))) - (tramp-run-real-handler #'find-backup-file-name (list filename))))) + backup-directory-alist)) + (uid (tramp-compat-file-attribute-user-id + (file-attributes filename 'integer))) + result) + (prog1 ;; Run plain `find-backup-file-name'. + (setq result + (tramp-run-real-handler + #'find-backup-file-name (list filename))) + ;; Protect against security hole. + (when (and (natnump uid) (zerop uid) + (file-in-directory-p (car result) temporary-file-directory) + (not tramp-allow-unsafe-temporary-files) + (not (with-tramp-connection-property + (tramp-get-process v) "unsafe-temporary-file" + (yes-or-no-p + (concat + "Backup file on local temporary directory, " + "do you want to continue? "))))) + (tramp-error v 'file-error "Unsafe backup file name")))))) (defun tramp-handle-insert-directory (filename switches &optional wildcard full-directory-p) @@ -5225,37 +5247,52 @@ Return the local name of the temporary file." "Like `make-auto-save-file-name' for Tramp files. Returns a file name in `tramp-auto-save-directory' for autosaving this file, if that variable is non-nil." - (when (stringp tramp-auto-save-directory) - (setq tramp-auto-save-directory - (expand-file-name tramp-auto-save-directory))) - ;; Create directory. - (unless (or (null tramp-auto-save-directory) - (file-exists-p tramp-auto-save-directory)) - (make-directory tramp-auto-save-directory t)) - - (let ((system-type - (if (and (stringp tramp-auto-save-directory) - (tramp-tramp-file-p tramp-auto-save-directory)) - 'not-windows - system-type)) - (auto-save-file-name-transforms - (if (null tramp-auto-save-directory) - auto-save-file-name-transforms)) - (buffer-file-name - (if (null tramp-auto-save-directory) - buffer-file-name - (expand-file-name - (tramp-subst-strs-in-string - '(("_" . "|") - ("/" . "_a") - (":" . "_b") - ("|" . "__") - ("[" . "_l") - ("]" . "_r")) - (tramp-compat-file-name-unquote (buffer-file-name))) - tramp-auto-save-directory)))) - ;; Run plain `make-auto-save-file-name'. - (tramp-run-real-handler #'make-auto-save-file-name nil))) + (with-parsed-tramp-file-name buffer-file-name nil + (when (stringp tramp-auto-save-directory) + (setq tramp-auto-save-directory + (expand-file-name tramp-auto-save-directory))) + ;; Create directory. + (unless (or (null tramp-auto-save-directory) + (file-exists-p tramp-auto-save-directory)) + (make-directory tramp-auto-save-directory t)) + + (let ((system-type + (if (and (stringp tramp-auto-save-directory) + (tramp-tramp-file-p tramp-auto-save-directory)) + 'not-windows + system-type)) + (auto-save-file-name-transforms + (if (null tramp-auto-save-directory) + auto-save-file-name-transforms)) + (uid (tramp-compat-file-attribute-user-id + (file-attributes buffer-file-name 'integer))) + (buffer-file-name + (if (null tramp-auto-save-directory) + buffer-file-name + (expand-file-name + (tramp-subst-strs-in-string + '(("_" . "|") + ("/" . "_a") + (":" . "_b") + ("|" . "__") + ("[" . "_l") + ("]" . "_r")) + (tramp-compat-file-name-unquote (buffer-file-name))) + tramp-auto-save-directory))) + result) + (prog1 ;; Run plain `make-auto-save-file-name'. + (setq result (tramp-run-real-handler #'make-auto-save-file-name nil)) + ;; Protect against security hole. + (when (and (natnump uid) (zerop uid) + (file-in-directory-p result temporary-file-directory) + (not tramp-allow-unsafe-temporary-files) + (not (with-tramp-connection-property + (tramp-get-process v) "unsafe-temporary-file" + (yes-or-no-p + (concat + "Autosave file on local temporary directory, " + "do you want to continue? "))))) + (tramp-error v 'file-error "Unsafe autosave file name")))))) (defun tramp-subst-strs-in-string (alist string) "Replace all occurrences of the string FROM with TO in STRING. diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 5e4626ab41a..37cd7011618 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -229,6 +229,16 @@ is greater than 10. "%s %f sec" ,message (float-time (time-subtract (current-time) start)))))) +;; `always' is introduced with Emacs 28.1. +(defalias 'tramp--test-always + (if (fboundp 'always) + #'always + (lambda (&rest _arguments) + "Do nothing and return t. +This function accepts any number of ARGUMENTS, but ignores them. +Also see `ignore'." + t))) + (ert-deftest tramp-test00-availability () "Test availability of Tramp functions." :expected-result (if (tramp--test-enabled) :passed :failed) @@ -2454,9 +2464,9 @@ This checks also `file-name-as-directory', `file-name-directory', tramp--test-messages)))))))) ;; Do not overwrite if excluded. - (cl-letf (((symbol-function #'y-or-n-p) (lambda (_prompt) t)) + (cl-letf (((symbol-function #'y-or-n-p) #'tramp--test-always) ;; Ange-FTP. - ((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) + ((symbol-function 'yes-or-no-p) #'tramp--test-always)) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) ;; `mustbenew' is passed to Tramp since Emacs 26.1. (when (tramp--test-emacs26-p) @@ -3671,7 +3681,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should-error (make-symbolic-link tmp-name1 tmp-name2 0) :type 'file-already-exists))) - (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_prompt) t))) + (cl-letf (((symbol-function #'yes-or-no-p) #'tramp--test-always)) (make-symbolic-link tmp-name1 tmp-name2 0) (should (string-equal @@ -3747,7 +3757,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should-error (add-name-to-file tmp-name1 tmp-name2 0) :type 'file-already-exists)) - (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_prompt) t))) + (cl-letf (((symbol-function #'yes-or-no-p) #'tramp--test-always)) (add-name-to-file tmp-name1 tmp-name2 0) (should (file-regular-p tmp-name2))) (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists) @@ -4545,7 +4555,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." If UNSTABLE is non-nil, the test is tagged as `:unstable'." (declare (indent 1)) ;; `make-process' supports file name handlers since Emacs 27. - (when (let ((file-name-handler-alist '(("" . (lambda (&rest _) t))))) + (when (let ((file-name-handler-alist '(("" . #'tramp--test-always)))) (ignore-errors (make-process :file-handler t))) `(ert-deftest ,(intern (concat (symbol-name test) "-direct-async")) () ,docstring @@ -4561,7 +4571,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; `file-truename' does it by side-effect. Suppress ;; `tramp--test-enabled', in order to keep the connection. ;; Suppress "Process ... finished" messages. - (cl-letf (((symbol-function #'tramp--test-enabled) (lambda nil t)) + (cl-letf (((symbol-function #'tramp--test-enabled) #'tramp--test-always) ((symbol-function #'internal-default-process-sentinel) #'ignore)) (file-truename tramp-test-temporary-file-directory) @@ -5554,11 +5564,38 @@ Use direct async.") ("]" . "_r")) (tramp-compat-file-name-unquote tmp-name1))) tmp-name2))) - (should (file-directory-p tmp-name2)))))) + (should (file-directory-p tmp-name2))))) + + ;; Create temporary file. This shall check for sensible + ;; files, owned by root. + (let ((tramp-auto-save-directory temporary-file-directory) + tramp-allow-unsafe-temporary-files) + (write-region "foo" nil tmp-name1) + (when (zerop (or (tramp-compat-file-attribute-user-id + (file-attributes tmp-name1)) + tramp-unknown-id-integer)) + (with-temp-buffer + (setq buffer-file-name tmp-name1) + (tramp-cleanup-connection + tramp-test-vec 'keep-debug 'keep-password) + (let ((tramp-allow-unsafe-temporary-files t)) + (should (stringp (make-auto-save-file-name)))) + (tramp-cleanup-connection + tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) + (should-error + (make-auto-save-file-name) + :type 'file-error)) + (tramp-cleanup-connection + tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'yes-or-no-p) + #'tramp--test-always)) + (should (stringp (make-auto-save-file-name)))))))) ;; Cleanup. (ignore-errors (delete-file tmp-name1)) - (ignore-errors (delete-directory tmp-name2 'recursive)))))) + (ignore-errors (delete-directory tmp-name2 'recursive)) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password))))) (ert-deftest tramp-test38-find-backup-file-name () "Check `find-backup-file-name'." @@ -5672,7 +5709,37 @@ Use direct async.") (should (file-directory-p tmp-name2)))) ;; Cleanup. - (ignore-errors (delete-directory tmp-name2 'recursive)))))) + (ignore-errors (delete-directory tmp-name2 'recursive))) + + (unwind-protect + ;; Create temporary file. This shall check for sensible + ;; files, owned by root. + (let ((backup-directory-alist `(("." . ,temporary-file-directory))) + tramp-allow-unsafe-temporary-files + tramp-backup-directory-alist) + (write-region "foo" nil tmp-name1) + (when (zerop (or (tramp-compat-file-attribute-user-id + (file-attributes tmp-name1)) + tramp-unknown-id-integer)) + (tramp-cleanup-connection + tramp-test-vec 'keep-debug 'keep-password) + (let ((tramp-allow-unsafe-temporary-files t)) + (should (stringp (car (find-backup-file-name tmp-name1))))) + (tramp-cleanup-connection + tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) + (should-error + (find-backup-file-name tmp-name1) + :type 'file-error)) + (tramp-cleanup-connection + tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'yes-or-no-p) + #'tramp--test-always)) + (should (stringp (car (find-backup-file-name tmp-name1))))))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password))))) ;; The functions were introduced in Emacs 26.1. (ert-deftest tramp-test39-make-nearby-temp-file () -- cgit v1.2.3 From cd339e85a695f40d93b5ce9f4e65075dd979b25b Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Tue, 29 Jun 2021 17:15:55 +0200 Subject: Sync with Tramp 2.5.1 * doc/misc/trampver.texi: * lisp/net/trampver.el: Change version to "2.5.1". * lisp/tramp.el (tramp-handle-write-region): * lisp/tramp-adb.el (tramp-adb-handle-write-region): * lisp/tramp-sh.el (tramp-sh-handle-write-region): Call local `write-region' directly. * test/lisp/net/tramp-tests.el (tramp--test-utf8): Adapt test for MS Windows. --- doc/misc/trampver.texi | 2 +- lisp/net/tramp-adb.el | 3 +-- lisp/net/tramp-sh.el | 12 +++--------- lisp/net/tramp.el | 3 +-- lisp/net/trampver.el | 6 +++--- test/lisp/net/tramp-tests.el | 5 +++-- 6 files changed, 12 insertions(+), 19 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/doc/misc/trampver.texi b/doc/misc/trampver.texi index 827c4773285..10c951d3ccf 100644 --- a/doc/misc/trampver.texi +++ b/doc/misc/trampver.texi @@ -8,7 +8,7 @@ @c In the Tramp GIT, the version numbers are auto-frobbed from @c tramp.el, and the bug report address is auto-frobbed from @c configure.ac. -@set trampver 2.5.1-pre +@set trampver 2.5.1 @set trampurl https://www.gnu.org/software/tramp/ @set tramp-bug-report-address tramp-devel@@gnu.org @set emacsver 25.1 diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index aacf83e663f..7fb0ff57808 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -549,8 +549,7 @@ But handle the case, if the \"test\" command is not available." (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok) (set-file-modes tmpfile (logior (or (file-modes tmpfile) 0) #o0600))) - (tramp-run-real-handler - #'write-region (list start end tmpfile append 'no-message lockname)) + (write-region start end tmpfile append 'no-message lockname) (with-tramp-progress-reporter v 3 (format-message "Moving tmp file `%s' to `%s'" tmpfile filename) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index b613ad3f8e7..ebd0fbfd2d9 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -3225,7 +3225,6 @@ implementation will be used." (run-hooks 'tramp-handle-file-local-copy-hook) tmpfile))) -;; CCC grok LOCKNAME (defun tramp-sh-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." @@ -3254,9 +3253,7 @@ implementation will be used." (or (file-directory-p localname) (file-writable-p localname))))) ;; Short track: if we are on the local host, we can run directly. - (tramp-run-real-handler - #'write-region - (list start end localname append 'no-message lockname)) + (write-region start end localname append 'no-message lockname) (let* ((modes (tramp-default-file-modes filename (and (eq mustbenew 'excl) 'nofollow))) @@ -3289,13 +3286,10 @@ implementation will be used." ;; file. We call `set-visited-file-modtime' ourselves later ;; on. We must ensure that `file-coding-system-alist' ;; matches `tmpfile'. - (let (file-name-handler-alist - (file-coding-system-alist + (let ((file-coding-system-alist (tramp-find-file-name-coding-system-alist filename tmpfile))) (condition-case err - (tramp-run-real-handler - #'write-region - (list start end tmpfile append 'no-message lockname)) + (write-region start end tmpfile append 'no-message lockname) ((error quit) (setq tramp-temp-buffer-file-name nil) (delete-file tmpfile) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index c3b088aebb7..ee7e0cf2c3b 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -4393,8 +4393,7 @@ of." ;; We say `no-message' here because we don't want the visited file ;; modtime data to be clobbered from the temp file. We call ;; `set-visited-file-modtime' ourselves later on. - (tramp-run-real-handler - #'write-region (list start end tmpfile append 'no-message lockname)) + (write-region start end tmpfile append 'no-message lockname) (condition-case nil (rename-file tmpfile filename 'ok-if-already-exists) (error diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index abd92219b27..e6cf4c6ac53 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.5.1-pre +;; Version: 2.5.1 ;; Package-Requires: ((emacs "25.1")) ;; Package-Type: multi ;; URL: https://www.gnu.org/software/tramp/ @@ -40,7 +40,7 @@ ;; ./configure" to change them. ;;;###tramp-autoload -(defconst tramp-version "2.5.1-pre" +(defconst tramp-version "2.5.1" "This version of Tramp.") ;;;###tramp-autoload @@ -76,7 +76,7 @@ ;; Check for Emacs version. (let ((x (if (not (string-lessp emacs-version "25.1")) "ok" - (format "Tramp 2.5.1-pre is not fit for %s" + (format "Tramp 2.5.1 is not fit for %s" (replace-regexp-in-string "\n" "" (emacs-version)))))) (unless (string-equal "ok" x) (error "%s" x))) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 37cd7011618..6aa8629f334 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -6280,8 +6280,9 @@ Use the `ls' command." x "")) (not (string-empty-p x)) ;; ?\n and ?/ shouldn't be part of any file name. ?\t, - ;; ?. and ?? do not work for "smb" method. - (replace-regexp-in-string "[\t\n/.?]" "" x))) + ;; ?. and ?? do not work for "smb" method. " " does not + ;; work at begin or end of the string for MS Windows. + (replace-regexp-in-string "[ \t\n/.?]" "" x))) language-info-alist))))))) (ert-deftest tramp-test41-utf8 () -- cgit v1.2.3 From 225ca617b70d3c70376c2d9bf38ced2f2323b26e Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Fri, 2 Jul 2021 14:51:23 +0200 Subject: Implement another fix for bug#49229 * lisp/minibuffer.el (read-file-name-default): Respect remote files. (Bug#49229) * lisp/net/tramp-sh.el (tramp-sh-handle-expand-file-name): Handle special file names on MS Windows. * lisp/net/tramp.el (tramp-file-name-handler): Revert patch. (Bug#49229) --- lisp/minibuffer.el | 1 + lisp/net/tramp-sh.el | 107 +++++++++++++++++++++++++++------------------------ lisp/net/tramp.el | 9 +---- 3 files changed, 59 insertions(+), 58 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 71a2177c9b1..813ce14c59b 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -3161,6 +3161,7 @@ See `read-file-name' for the meaning of the arguments." (unless val (error "No file name specified")) (if (and default-filename + (not (file-remote-p dir)) (string-equal val (if (consp insdef) (car insdef) insdef))) (setq val default-filename)) (setq val (substitute-in-file-name val)) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index ebd0fbfd2d9..88caa2fb7ba 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2667,56 +2667,63 @@ the result will be a local, non-Tramp, file name." (setq dir (or dir default-directory "/")) ;; Handle empty NAME. (when (zerop (length name)) (setq name ".")) - ;; Unless NAME is absolute, concat DIR and NAME. - (unless (file-name-absolute-p name) - (setq name (concat (file-name-as-directory dir) name))) - ;; If connection is not established yet, run the real handler. - (if (not (tramp-connectable-p name)) - (tramp-run-real-handler #'expand-file-name (list name nil)) - ;; Dissect NAME. - (with-parsed-tramp-file-name name nil - (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) - (setq localname (concat "~/" localname))) - ;; Tilde expansion if necessary. This needs a shell which - ;; groks tilde expansion! The function `tramp-find-shell' is - ;; supposed to find such a shell on the remote host. Please - ;; tell me about it when this doesn't work on your system. - (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) - (let ((uname (match-string 1 localname)) - (fname (match-string 2 localname))) - ;; We cannot simply apply "~/", because under sudo "~/" is - ;; expanded to the local user home directory but to the - ;; root home directory. On the other hand, using always - ;; the default user name for tilde expansion is not - ;; appropriate either, because ssh and companions might - ;; use a user name from the config file. - (when (and (string-equal uname "~") - (string-match-p "\\`su\\(do\\)?\\'" method)) - (setq uname (concat uname user))) - (setq uname - (with-tramp-connection-property v uname - (tramp-send-command - v (format "cd %s && pwd" (tramp-shell-quote-argument uname))) - (with-current-buffer (tramp-get-buffer v) - (goto-char (point-min)) - (buffer-substring (point) (point-at-eol))))) - (setq localname (concat uname fname)))) - ;; There might be a double slash, for example when "~/" - ;; expands to "/". Remove this. - (while (string-match "//" localname) - (setq localname (replace-match "/" t t localname))) - ;; Do not keep "/..". - (when (string-match-p "^/\\.\\.?$" localname) - (setq localname "/")) - ;; No tilde characters in file name, do normal - ;; `expand-file-name' (this does "/./" and "/../"). - ;; `default-directory' is bound, because on Windows there would - ;; be problems with UNC shares or Cygwin mounts. - (let ((default-directory (tramp-compat-temporary-file-directory))) - (tramp-make-tramp-file-name - v (tramp-drop-volume-letter - (tramp-run-real-handler - #'expand-file-name (list localname)))))))) + ;; On MS Windows, some special file names are not returned properly + ;; by `file-name-absolute-p'. + (if (and (eq system-type 'windows-nt) + (string-match-p + (concat "^\\([[:alpha:]]:\\|" null-device "$\\)") name)) + (tramp-run-real-handler #'expand-file-name (list name dir)) + ;; Unless NAME is absolute, concat DIR and NAME. + (unless (file-name-absolute-p name) + (setq name (concat (file-name-as-directory dir) name))) + ;; If connection is not established yet, run the real handler. + (if (not (tramp-connectable-p name)) + (tramp-run-real-handler #'expand-file-name (list name nil)) + ;; Dissect NAME. + (with-parsed-tramp-file-name name nil + (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) + (setq localname (concat "~/" localname))) + ;; Tilde expansion if necessary. This needs a shell which + ;; groks tilde expansion! The function `tramp-find-shell' is + ;; supposed to find such a shell on the remote host. Please + ;; tell me about it when this doesn't work on your system. + (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + (let ((uname (match-string 1 localname)) + (fname (match-string 2 localname))) + ;; We cannot simply apply "~/", because under sudo "~/" is + ;; expanded to the local user home directory but to the + ;; root home directory. On the other hand, using always + ;; the default user name for tilde expansion is not + ;; appropriate either, because ssh and companions might + ;; use a user name from the config file. + (when (and (string-equal uname "~") + (string-match-p "\\`su\\(do\\)?\\'" method)) + (setq uname (concat uname user))) + (setq uname + (with-tramp-connection-property v uname + (tramp-send-command + v + (format "cd %s && pwd" (tramp-shell-quote-argument uname))) + (with-current-buffer (tramp-get-buffer v) + (goto-char (point-min)) + (buffer-substring (point) (point-at-eol))))) + (setq localname (concat uname fname)))) + ;; There might be a double slash, for example when "~/" + ;; expands to "/". Remove this. + (while (string-match "//" localname) + (setq localname (replace-match "/" t t localname))) + ;; Do not keep "/..". + (when (string-match-p "^/\\.\\.?$" localname) + (setq localname "/")) + ;; No tilde characters in file name, do normal + ;; `expand-file-name' (this does "/./" and "/../"). + ;; `default-directory' is bound, because on Windows there + ;; would be problems with UNC shares or Cygwin mounts. + (let ((default-directory (tramp-compat-temporary-file-directory))) + (tramp-make-tramp-file-name + v (tramp-drop-volume-letter + (tramp-run-real-handler + #'expand-file-name (list localname))))))))) ;;; Remote commands: diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index ee7e0cf2c3b..75e44551ef9 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2610,14 +2610,7 @@ Fall back to normal file name handler if no Tramp file name handler exists." ;; When `tramp-mode' is not enabled, or the file name is quoted, ;; we don't do anything. - ;; When operation is `expand-file-name', and the first argument - ;; is a local absolute file name, we end also here. Handle the - ;; MS Windows case. - (funcall - (if (and (eq operation 'expand-file-name) - (not (string-match-p "\\`[[:alpha:]]:/" (car args)))) - #'tramp-drop-volume-letter #'identity) - (tramp-run-real-handler operation args))))) + (tramp-run-real-handler operation args)))) (defun tramp-completion-file-name-handler (operation &rest args) "Invoke Tramp file name completion handler for OPERATION and ARGS. -- cgit v1.2.3 From 579b0c006e407aef1623f3b42d28b666426406c7 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Mon, 5 Jul 2021 12:09:28 +0200 Subject: Don't use LOCKNAME for temp files in Tramp (Bug#49406) * lisp/net/tramp.el (tramp-handle-write-region): * lisp/net/tramp-adb.el (tramp-adb-handle-write-region): * lisp/net/tramp-sh.el (tramp-sh-handle-write-region): * lisp/net/tramp-smb.el (tramp-smb-handle-write-region): * lisp/net/tramp-sshfs.el (tramp-sshfs-handle-write-region): Don't use LOCKNAME for temp file. (Bug#49406) * test/lisp/shadowfile-tests.el (password-cache-expiry): Set `shadow-debug' also on emba. --- lisp/net/tramp-adb.el | 4 ++-- lisp/net/tramp-sh.el | 6 +++--- lisp/net/tramp-smb.el | 5 ++--- lisp/net/tramp-sshfs.el | 4 ++-- lisp/net/tramp.el | 4 ++-- test/lisp/shadowfile-tests.el | 2 +- 6 files changed, 12 insertions(+), 13 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 7fb0ff57808..f9569523d94 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -533,7 +533,7 @@ But handle the case, if the \"test\" command is not available." rw-path))))))) (defun tramp-adb-handle-write-region - (start end filename &optional append visit lockname mustbenew) + (start end filename &optional append visit _lockname mustbenew) "Like `write-region' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil @@ -549,7 +549,7 @@ But handle the case, if the \"test\" command is not available." (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok) (set-file-modes tmpfile (logior (or (file-modes tmpfile) 0) #o0600))) - (write-region start end tmpfile append 'no-message lockname) + (write-region start end tmpfile append 'no-message) (with-tramp-progress-reporter v 3 (format-message "Moving tmp file `%s' to `%s'" tmpfile filename) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 88caa2fb7ba..5f597ff46e4 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -3233,7 +3233,7 @@ implementation will be used." tmpfile))) (defun tramp-sh-handle-write-region - (start end filename &optional append visit lockname mustbenew) + (start end filename &optional append visit _lockname mustbenew) "Like `write-region' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil @@ -3260,7 +3260,7 @@ implementation will be used." (or (file-directory-p localname) (file-writable-p localname))))) ;; Short track: if we are on the local host, we can run directly. - (write-region start end localname append 'no-message lockname) + (write-region start end localname append 'no-message) (let* ((modes (tramp-default-file-modes filename (and (eq mustbenew 'excl) 'nofollow))) @@ -3296,7 +3296,7 @@ implementation will be used." (let ((file-coding-system-alist (tramp-find-file-name-coding-system-alist filename tmpfile))) (condition-case err - (write-region start end tmpfile append 'no-message lockname) + (write-region start end tmpfile append 'no-message) ((error quit) (setq tramp-temp-buffer-file-name nil) (delete-file tmpfile) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 6fbf08801e8..13edf16756f 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -1573,7 +1573,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (error filename)))) (defun tramp-smb-handle-write-region - (start end filename &optional append visit lockname mustbenew) + (start end filename &optional append visit _lockname mustbenew) "Like `write-region' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil @@ -1591,8 +1591,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." ;; We say `no-message' here because we don't want the visited file ;; modtime data to be clobbered from the temp file. We call ;; `set-visited-file-modtime' ourselves later on. - (tramp-run-real-handler - #'write-region (list start end tmpfile append 'no-message lockname)) + (write-region start end tmpfile append 'no-message) (with-tramp-progress-reporter v 3 (format "Moving tmp file %s to %s" tmpfile filename) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index c4a36fe2a3a..cac8c40abb3 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -279,7 +279,7 @@ arguments to pass to the OPERATION." (tramp-fuse-local-file-name filename) mode flag)))) (defun tramp-sshfs-handle-write-region - (start end filename &optional append visit lockname mustbenew) + (start end filename &optional append visit _lockname mustbenew) "Like `write-region' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil @@ -291,7 +291,7 @@ arguments to pass to the OPERATION." (tramp-error v 'file-already-exists filename)) (write-region - start end (tramp-fuse-local-file-name filename) append 'nomessage lockname) + start end (tramp-fuse-local-file-name filename) append 'nomessage) (tramp-flush-file-properties v localname) ;; The end. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 75e44551ef9..04ec06d2512 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -4355,7 +4355,7 @@ of." (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist)))))))) (defun tramp-handle-write-region - (start end filename &optional append visit lockname mustbenew) + (start end filename &optional append visit _lockname mustbenew) "Like `write-region' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil @@ -4386,7 +4386,7 @@ of." ;; We say `no-message' here because we don't want the visited file ;; modtime data to be clobbered from the temp file. We call ;; `set-visited-file-modtime' ourselves later on. - (write-region start end tmpfile append 'no-message lockname) + (write-region start end tmpfile append 'no-message) (condition-case nil (rename-file tmpfile filename 'ok-if-already-exists) (error diff --git a/test/lisp/shadowfile-tests.el b/test/lisp/shadowfile-tests.el index 7c9d05ac1c7..84a9479480e 100644 --- a/test/lisp/shadowfile-tests.el +++ b/test/lisp/shadowfile-tests.el @@ -70,7 +70,7 @@ "Temporary directory for Tramp tests.") (setq password-cache-expiry nil - shadow-debug (getenv "EMACS_HYDRA_CI") + shadow-debug (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI")) tramp-verbose 0 ;; When the remote user id is 0, Tramp refuses unsafe temporary files. tramp-allow-unsafe-temporary-files -- cgit v1.2.3 From d35868bec96718705c9bc8aaac3bc583c837033f Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Wed, 7 Jul 2021 18:36:53 +0200 Subject: Implement file locks for remote files (Bug#49261) * doc/lispref/files.texi (Magic File Names): Add file-locked-p, lock-file and unlock-file. * etc/NEWS: Tramp supports file locks now. * lisp/net/tramp-adb.el (tramp-adb-file-name-handler-alist): Add `file-locked-p', `lock-file' and `unlock-file'. (tramp-adb-handle-write-region): Handle LOCKNAME. * lisp/net/tramp-archive.el (tramp-archive-file-name-handler-alist): Add `file-locked-p', `lock-file' and `unlock-file'. * lisp/net/tramp-crypt.el (tramp-crypt-file-name-handler-alist): Add `file-locked-p', `lock-file' and `unlock-file'. (tramp-crypt-handle-file-locked-p, tramp-crypt-handle-lock-file) (tramp-crypt-handle-unlock-file): New defun. * lisp/net/tramp-fuse.el (tramp-fuse-mounted-p): Simplify. (tramp-fuse-unmount): New defun. * lisp/net/tramp-gvfs.el (tramp-gvfs-file-name-handler-alist): Add `file-locked-p', `lock-file' and `unlock-file'. (tramp-gvfs-maybe-open-connection): Set "lock-pid" connection property. * lisp/net/tramp-rclone.el (tramp-rclone-file-name-handler-alist): Add `file-locked-p', `lock-file' and `unlock-file'. (tramp-rclone-maybe-open-connection): Set "lock-pid" connection property. * lisp/net/tramp-sh.el (tramp-sh-file-name-handler-alist): Add `file-locked-p', `lock-file' and `unlock-file'. (tramp-sh-handle-write-region): Handle LOCKNAME. * lisp/net/tramp-smb.el (tramp-smb-file-name-handler-alist): Add `file-locked-p', `lock-file' and `unlock-file'. (tramp-smb-handle-copy-directory): Use `sleep-for'. (tramp-smb-handle-write-region): Handle LOCKNAME. * lisp/net/tramp-sshfs.el (tramp-sshfs-file-name-handler-alist): Add `file-locked-p', `lock-file' and `unlock-file'. (tramp-sshfs-handle-write-region): Handle LOCKNAME. (tramp-sshfs-maybe-open-connection): Set "lock-pid" connection property. * lisp/net/tramp-sudoedit.el (tramp-sudoedit-file-name-handler-alist): Add `file-locked-p', `lock-file' and `unlock-file'. (tramp-sudoedit-maybe-open-connection): Set "lock-pid" connection property. * lisp/net/tramp.el (tramp-file-name-for-operation): Add `file-locked-p', `lock-file' and `unlock-file'. (tramp-make-lock-name, tramp-get-lock-file, tramp-get-lock-pid) (tramp-handle-file-locked-p, tramp-handle-lock-file) (tramp-handle-unlock-file): New defuns. (tramp-lock-file-contents-regexp): New regexp. (tramp-handle-write-region): Handle LOCKNAME. * src/filelock.c (lock_file, unlock_file_body, Ffile_locked_p): Call handler if exists. (Flock_file, Funlock_file): New defuns. (Qlock_file, Qunlock_file, Qfile_locked_p): Declare symbols. (Slock_file, Sunlock_file): Declare subroutines. * test/lisp/net/tramp-archive-tests.el (tramp-archive-test40-make-nearby-temp-file) (tramp-archive-test43-file-system-info): Rename. * test/lisp/net/tramp-tests.el (top): Set `create-lockfiles' to nil. (tramp--test-fuse-p): New defun. (tramp-test14-delete-directory): Use it. (tramp-test39-lock-file): New test. (tramp-test40-make-nearby-temp-file) (tramp-test41-special-characters) (tramp-test41-special-characters-with-stat) (tramp-test41-special-characters-with-perl) (tramp-test41-special-characters-with-ls, tramp-test42-utf8) (tramp-test42-utf8-with-stat, tramp-test42-utf8-with-perl) (tramp-test42-utf8-with-ls, tramp-test43-file-system-info) (tramp-test44-asynchronous-requests, tramp-test45-auto-load) (tramp-test45-delay-load, tramp-test45-recursive-load) (tramp-test45-remote-load-path, tramp-test46-unload): Rename. (tramp--test-special-characters, tramp--test-utf8) (tramp--test-asynchronous-requests-timeout): Modify docstring. --- doc/lispref/files.texi | 10 +-- etc/NEWS | 6 +- lisp/net/tramp-adb.el | 30 +++++++-- lisp/net/tramp-archive.el | 3 + lisp/net/tramp-cache.el | 2 + lisp/net/tramp-crypt.el | 18 +++++ lisp/net/tramp-fuse.el | 17 +++-- lisp/net/tramp-gvfs.el | 6 ++ lisp/net/tramp-rclone.el | 7 ++ lisp/net/tramp-sh.el | 26 +++++++- lisp/net/tramp-smb.el | 28 ++++++-- lisp/net/tramp-sshfs.el | 46 ++++++++++--- lisp/net/tramp-sudoedit.el | 7 ++ lisp/net/tramp.el | 109 +++++++++++++++++++++++++++--- src/filelock.c | 58 +++++++++++++++- test/lisp/net/tramp-archive-tests.el | 4 +- test/lisp/net/tramp-tests.el | 125 ++++++++++++++++++++++++++++------- 17 files changed, 432 insertions(+), 70 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index 5238597a465..ae763a21afe 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -3273,7 +3273,7 @@ first, before handlers for jobs such as remote file access. @code{file-equal-p}, @code{file-executable-p}, @code{file-exists-p}, @code{file-in-directory-p}, -@code{file-local-copy}, +@code{file-local-copy}, @code{file-locked-p}, @code{file-modes}, @code{file-name-all-completions}, @code{file-name-as-directory}, @code{file-name-case-insensitive-p}, @@ -3292,7 +3292,7 @@ first, before handlers for jobs such as remote file access. @code{get-file-buffer}, @code{insert-directory}, @code{insert-file-contents},@* -@code{load}, +@code{load}, @code{lock-file}, @code{make-auto-save-file-name}, @code{make-directory}, @code{make-directory-internal}, @@ -3307,6 +3307,7 @@ first, before handlers for jobs such as remote file access. @code{substitute-in-file-name},@* @code{temporary-file-directory}, @code{unhandled-file-name-directory}, +@code{unlock-file}, @code{vc-registered}, @code{verify-visited-file-modtime},@* @code{write-region}. @@ -3331,7 +3332,7 @@ first, before handlers for jobs such as remote file access. @code{file-equal-p}, @code{file-executable-p}, @code{file-exists-p}, @code{file-in-directory-p}, -@code{file-local-copy}, +@code{file-local-copy}, @code{file-locked-p}, @code{file-modes}, @code{file-name-all-completions}, @code{file-name-as-directory}, @code{file-name-case-insensitive-p}, @@ -3350,7 +3351,7 @@ first, before handlers for jobs such as remote file access. @code{get-file-buffer}, @code{insert-directory}, @code{insert-file-contents}, -@code{load}, +@code{load}, @code{lock-file}, @code{make-auto-save-file-name}, @code{make-direc@discretionary{}{}{}tory}, @code{make-direc@discretionary{}{}{}tory-internal}, @@ -3363,6 +3364,7 @@ first, before handlers for jobs such as remote file access. @code{start-file-process}, @code{substitute-in-file-name}, @code{unhandled-file-name-directory}, +@code{unlock-file}, @code{vc-regis@discretionary{}{}{}tered}, @code{verify-visited-file-modtime}, @code{write-region}. diff --git a/etc/NEWS b/etc/NEWS index 7bf8c1d8f56..0e8a846408e 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -323,6 +323,7 @@ emulators by using the new input-meta-mode with the special value ** New frame parameter 'drag-with-tab-line'. This parameter, similar to 'drag-with-header-line', allows moving frames by dragging the tab lines of their topmost windows with the mouse. + * Editing Changes in Emacs 28.1 @@ -1467,6 +1468,9 @@ rare cases) Tramp blocks Emacs, and we need further debug information. directory must be confirmed. In order to suppress this confirmation, set user option 'tramp-allow-unsafe-temporary-files' to t. ++++ +*** Tramp supports file locks now. + ** Tempo --- @@ -2932,7 +2936,7 @@ The former is now declared obsolete. * Lisp Changes in Emacs 28.1 --- -*** :safe settings in 'defcustom' are now propagated to the loaddefs files. +*** ':safe' settings in 'defcustom' are now propagated to the loaddefs files. +++ ** New function 'syntax-class-to-char'. diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index f9569523d94..9c1c8aca1ca 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -133,6 +133,7 @@ It is used for TCP/IP devices." (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-adb-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-adb-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) @@ -159,6 +160,7 @@ It is used for TCP/IP devices." (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-adb-handle-make-directory) (make-directory-internal . ignore) @@ -180,6 +182,7 @@ It is used for TCP/IP devices." (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-adb-handle-write-region)) @@ -533,9 +536,10 @@ But handle the case, if the \"test\" command is not available." rw-path))))))) (defun tramp-adb-handle-write-region - (start end filename &optional append visit _lockname mustbenew) + (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) + (setq filename (expand-file-name filename) + lockname (file-truename (or lockname filename))) (with-parsed-tramp-file-name filename nil (when (and mustbenew (file-exists-p filename) (or (eq mustbenew 'excl) @@ -544,15 +548,26 @@ But handle the case, if the \"test\" command is not available." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let* ((curbuf (current-buffer)) + (let* ((auto-saving + (string-match-p "^#.+#$" (file-name-nondirectory filename))) + file-locked + (curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) + + ;; Lock file. + (when (and (not auto-saving) (file-remote-p lockname) + (not (eq (file-locked-p lockname) t))) + (setq file-locked t) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'lock-file lockname)) + (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok) (set-file-modes tmpfile (logior (or (file-modes tmpfile) 0) #o0600))) (write-region start end tmpfile append 'no-message) (with-tramp-progress-reporter - v 3 (format-message - "Moving tmp file `%s' to `%s'" tmpfile filename) + v 3 (format-message + "Moving tmp file `%s' to `%s'" tmpfile filename) (unwind-protect (unless (tramp-adb-execute-adb-command v "push" tmpfile (tramp-compat-file-name-unquote localname)) @@ -575,6 +590,11 @@ But handle the case, if the \"test\" command is not available." (file-attributes filename)) (current-time)))) + ;; Unlock file. + (when (and file-locked (eq (file-locked-p lockname) t)) + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'unlock-file lockname)) + ;; The end. (when (and (null noninteractive) (or (eq visit t) (null visit) (stringp visit))) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index d723fd5c6d5..a6f479bcbcb 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -236,6 +236,7 @@ It must be supported by libarchive(3).") (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-locked-p . ignore) (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. @@ -262,6 +263,7 @@ It must be supported by libarchive(3).") (insert-directory . tramp-archive-handle-insert-directory) (insert-file-contents . tramp-archive-handle-insert-file-contents) (load . tramp-archive-handle-load) + (lock-file . ignore) (make-auto-save-file-name . ignore) (make-directory . tramp-archive-handle-not-implemented) (make-directory-internal . tramp-archive-handle-not-implemented) @@ -283,6 +285,7 @@ It must be supported by libarchive(3).") (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) + (unlock-file . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-archive-handle-not-implemented)) diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index a41620ab9f7..579234f9f50 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -49,6 +49,8 @@ ;; an open connection. Examples: "scripts" keeps shell script ;; definitions already sent to the remote shell, "last-cmd-time" is ;; the time stamp a command has been sent to the remote process. +;; "lock-pid" is the timestamp a (network) process is created, it is +;; used instead of the pid in file locks. ;; ;; - The key is nil. These are temporary properties related to the ;; local machine. Examples: "parse-passwd" and "parse-group" keep diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 1d8c0ad2170..31988bc9ef9 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -182,6 +182,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-handle-file-local-copy) + (file-locked-p . tramp-crypt-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-crypt-handle-file-name-all-completions) ;; `file-name-as-directory' performed by default handler. @@ -208,6 +209,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (insert-directory . tramp-crypt-handle-insert-directory) ;; `insert-file-contents' performed by default handler. (load . tramp-handle-load) + (lock-file . tramp-crypt-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-crypt-handle-make-directory) (make-directory-internal . ignore) @@ -229,6 +231,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." ;; `tramp-get-remote-uid' performed by default handler. (tramp-set-file-uid-gid . tramp-crypt-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-crypt-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-handle-write-region)) @@ -734,6 +737,11 @@ absolute file names." (let (tramp-crypt-enabled) (file-executable-p (tramp-crypt-encrypt-file-name filename)))) +(defun tramp-crypt-handle-file-locked-p (filename) + "Like `file-locked-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-locked-p (tramp-crypt-encrypt-file-name filename)))) + (defun tramp-crypt-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." (all-completions @@ -797,6 +805,11 @@ WILDCARD is not supported." (delete-region (prop-match-beginning match) (prop-match-end match)) (insert (propertize string 'dired-filename t))))))) +(defun tramp-crypt-handle-lock-file (filename) + "Like `lock-file' for Tramp files." + (let (tramp-crypt-enabled) + (lock-file (tramp-crypt-encrypt-file-name filename)))) + (defun tramp-crypt-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." (with-parsed-tramp-file-name (expand-file-name dir) nil @@ -848,6 +861,11 @@ WILDCARD is not supported." (tramp-set-file-uid-gid (tramp-crypt-encrypt-file-name filename) uid gid)))) +(defun tramp-crypt-handle-unlock-file (filename) + "Like `unlock-file' for Tramp files." + (let (tramp-crypt-enabled) + (unlock-file (tramp-crypt-encrypt-file-name filename)))) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-crypt 'force))) diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el index ec1db8680f2..93b184a36c2 100644 --- a/lisp/net/tramp-fuse.el +++ b/lisp/net/tramp-fuse.el @@ -164,10 +164,9 @@ (or (tramp-get-connection-property (tramp-get-connection-process vec) "mounted" nil) (let* ((default-directory (tramp-compat-temporary-file-directory)) - (fuse (concat "fuse." (tramp-file-name-method vec))) - (mount (shell-command-to-string (format "mount -t %s" fuse)))) - (tramp-message vec 6 "%s %s" "mount -t" fuse) - (tramp-message vec 6 "\n%s" mount) + (command (format "mount -t fuse.%s" (tramp-file-name-method vec))) + (mount (shell-command-to-string command))) + (tramp-message vec 6 "%s\n%s" command mount) (tramp-set-connection-property (tramp-get-connection-process vec) "mounted" (when (string-match @@ -176,6 +175,16 @@ mount) (match-string 1 mount))))))) +(defun tramp-fuse-unmount (vec) + "Unmount fuse volume determined by VEC." + (let ((default-directory (tramp-compat-temporary-file-directory)) + (command (format "fusermount3 -u %s" (tramp-fuse-mount-point vec)))) + (tramp-message vec 6 "%s\n%s" command (shell-command-to-string command)) + (tramp-flush-connection-property + (tramp-get-connection-process vec) "mounted") + ;; Give the caches a chance to expire. + (sleep-for 1))) + (defun tramp-fuse-local-file-name (filename) "Return local mount name of FILENAME." (setq filename (tramp-compat-file-name-unquote (expand-file-name filename))) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index f1d24dc0c41..e784ea83ef2 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -774,6 +774,7 @@ It has been changed in GVFS 1.14.") (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-gvfs-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) @@ -800,6 +801,7 @@ It has been changed in GVFS 1.14.") (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-gvfs-handle-make-directory) (make-directory-internal . ignore) @@ -821,6 +823,7 @@ It has been changed in GVFS 1.14.") (tramp-get-remote-uid . tramp-gvfs-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-gvfs-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-handle-write-region)) @@ -2144,6 +2147,9 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) + ;; Mark process for filelock. + (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) + ;; Set connection-local variables. (tramp-set-connection-local-variables vec))) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 3b6de3e0b70..6c710dd0b1b 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -96,6 +96,7 @@ (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-fuse-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) @@ -122,6 +123,7 @@ (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-fuse-handle-make-directory) (make-directory-internal . ignore) @@ -143,6 +145,7 @@ (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-handle-write-region)) @@ -358,6 +361,10 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) + ;; Mark process for filelock. + (tramp-set-connection-property + p "lock-pid" (truncate (time-to-seconds))) + ;; Set connection-local variables. (tramp-set-connection-local-variables vec))) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 5f597ff46e4..11037227790 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -962,6 +962,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (file-exists-p . tramp-sh-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-sh-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-sh-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) @@ -988,6 +989,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (insert-directory . tramp-sh-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (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. @@ -1009,6 +1011,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (tramp-get-remote-uid . tramp-sh-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sh-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . tramp-sh-handle-vc-registered) (verify-visited-file-modtime . tramp-sh-handle-verify-visited-file-modtime) (write-region . tramp-sh-handle-write-region)) @@ -3233,9 +3236,10 @@ implementation will be used." tmpfile))) (defun tramp-sh-handle-write-region - (start end filename &optional append visit _lockname mustbenew) + (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) + (setq filename (expand-file-name filename) + lockname (file-truename (or lockname filename))) (with-parsed-tramp-file-name filename nil (when (and mustbenew (file-exists-p filename) (or (eq mustbenew 'excl) @@ -3244,13 +3248,23 @@ implementation will be used." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let ((uid (or (tramp-compat-file-attribute-user-id + (let ((auto-saving + (string-match-p "^#.+#$" (file-name-nondirectory filename))) + file-locked + (uid (or (tramp-compat-file-attribute-user-id (file-attributes filename 'integer)) (tramp-get-remote-uid v 'integer))) (gid (or (tramp-compat-file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer)))) + ;; Lock file. + (when (and (not auto-saving) (file-remote-p lockname) + (not (eq (file-locked-p lockname) t))) + (setq file-locked t) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'lock-file lockname)) + (if (and (tramp-local-host-p v) ;; `file-writable-p' calls `file-expand-file-name'. We ;; cannot use `tramp-run-real-handler' therefore. @@ -3465,6 +3479,12 @@ implementation will be used." ;; Set the ownership. (when need-chown (tramp-set-file-uid-gid filename uid gid)) + + ;; Unlock file. + (when (and file-locked (eq (file-locked-p lockname) t)) + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'unlock-file lockname)) + (when (and (null noninteractive) (or (eq visit t) (null visit) (stringp visit))) (tramp-message v 0 "Wrote %s" filename)) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 13edf16756f..500245b3e19 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -247,6 +247,7 @@ See `tramp-actions-before-shell' for more info.") (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-smb-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-smb-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) @@ -273,6 +274,7 @@ See `tramp-actions-before-shell' for more info.") (insert-directory . tramp-smb-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-smb-handle-make-directory) (make-directory-internal . tramp-smb-handle-make-directory-internal) @@ -294,6 +296,7 @@ See `tramp-actions-before-shell' for more info.") (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-smb-handle-write-region)) @@ -532,7 +535,7 @@ arguments to pass to the OPERATION." (tramp-process-actions p v nil tramp-smb-actions-with-tar) (while (process-live-p p) - (sit-for 0.1)) + (sleep-for 0.1)) (tramp-message v 6 "\n%s" (buffer-string)))) ;; Reset the transfer process properties. @@ -1573,9 +1576,10 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (error filename)))) (defun tramp-smb-handle-write-region - (start end filename &optional append visit _lockname mustbenew) + (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) + (setq filename (expand-file-name filename) + lockname (file-truename (or lockname filename))) (with-parsed-tramp-file-name filename nil (when (and mustbenew (file-exists-p filename) (or (eq mustbenew 'excl) @@ -1584,8 +1588,19 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let ((curbuf (current-buffer)) + (let ((auto-saving + (string-match-p "^#.+#$" (file-name-nondirectory filename))) + file-locked + (curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) + + ;; Lock file. + (when (and (not auto-saving) (file-remote-p lockname) + (not (eq (file-locked-p lockname) t))) + (setq file-locked t) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'lock-file lockname)) + (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok)) ;; We say `no-message' here because we don't want the visited file @@ -1618,6 +1633,11 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (file-attributes filename)) (current-time)))) + ;; Unlock file. + (when (and file-locked (eq (file-locked-p lockname) t)) + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'unlock-file lockname)) + ;; The end. (when (and (null noninteractive) (or (eq visit t) (null visit) (stringp visit))) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index cac8c40abb3..babd770be9b 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -96,6 +96,7 @@ (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-fuse-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) @@ -122,6 +123,7 @@ (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-sshfs-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-fuse-handle-make-directory) (make-directory-internal . ignore) @@ -143,6 +145,7 @@ (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-sshfs-handle-write-region)) @@ -279,9 +282,10 @@ arguments to pass to the OPERATION." (tramp-fuse-local-file-name filename) mode flag)))) (defun tramp-sshfs-handle-write-region - (start end filename &optional append visit _lockname mustbenew) + (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) + (setq filename (expand-file-name filename) + lockname (file-truename (or lockname filename))) (with-parsed-tramp-file-name filename nil (when (and mustbenew (file-exists-p filename) (or (eq mustbenew 'excl) @@ -290,15 +294,32 @@ arguments to pass to the OPERATION." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (write-region - start end (tramp-fuse-local-file-name filename) append 'nomessage) - (tramp-flush-file-properties v localname) - - ;; The end. - (when (and (null noninteractive) - (or (eq visit t) (null visit) (stringp visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook))) + (let ((auto-saving + (string-match-p "^#.+#$" (file-name-nondirectory filename))) + file-locked) + + ;; Lock file. + (when (and (not auto-saving) (file-remote-p lockname) + (not (eq (file-locked-p lockname) t))) + (setq file-locked t) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'lock-file lockname)) + + (let (create-lockfiles) + (write-region + start end (tramp-fuse-local-file-name filename) append 'nomessage) + (tramp-flush-file-properties v localname)) + + ;; Unlock file. + (when (and file-locked (eq (file-locked-p lockname) t)) + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'unlock-file lockname)) + + ;; The end. + (when (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) + (tramp-message v 0 "Wrote %s" filename)) + (run-hooks 'tramp-handle-write-region-hook)))) ;; File name conversions. @@ -321,6 +342,9 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) + ;; Mark process for filelock. + (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) + ;; Set connection-local variables. (tramp-set-connection-local-variables vec) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index d6417094bae..aa6f85ec6ef 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -88,6 +88,7 @@ See `tramp-actions-before-shell' for more info.") (file-exists-p . tramp-sudoedit-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-sudoedit-handle-file-name-all-completions) @@ -115,6 +116,7 @@ See `tramp-actions-before-shell' for more info.") (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-sudoedit-handle-make-directory) (make-directory-internal . ignore) @@ -136,6 +138,7 @@ See `tramp-actions-before-shell' for more info.") (tramp-get-remote-uid . tramp-sudoedit-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sudoedit-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-sudoedit-handle-write-region)) @@ -713,6 +716,7 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-sudoedit-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." + (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil (let* ((uid (or (tramp-compat-file-attribute-user-id (file-attributes filename 'integer)) @@ -776,6 +780,9 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) + ;; Mark process for filelock. + (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) + ;; Set connection-local variables. (tramp-set-connection-local-variables vec) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 04ec06d2512..37d60e854f2 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2455,6 +2455,8 @@ Must be handled by the callers." file-name-case-insensitive-p ;; Emacs 27+ only. file-system-info + ;; Emacs 28+ only. + file-locked-p lock-file unlock-file ;; Tramp internal magic file name function. tramp-set-file-uid-gid)) (if (file-name-absolute-p (nth 0 args)) @@ -3816,6 +3818,76 @@ User is always nil." ;; Result. (cons (expand-file-name filename) (cdr result))))) +(defun tramp-make-lock-name (file) + "Implement MAKE_LOCK_NAME of filelock.c." + (expand-file-name + (concat ".#" (file-name-nondirectory file)) (file-name-directory file))) + +(defun tramp-get-lock-file (file) + "Read lockfile of FILE. +Return nil when there is no lockfile" + (let ((lockname (tramp-make-lock-name file))) + (or (file-symlink-p lockname) + (and (file-readable-p lockname) + (with-temp-buffer + (insert-file-contents-literally lockname) + (buffer-string)))))) + +(defun tramp-get-lock-pid (file) + "Determine pid for lockfile of FILE." + ;; Some Tramp methods do not offer a connection process, but just a + ;; network process as a place holder. Those processes use the + ;; "lock-pid" connection property as fake pid, in fact it is the + ;; time stamp the process is created. + (let ((p (tramp-get-process (tramp-dissect-file-name file)))) + (number-to-string + (or (process-id p) + (tramp-get-connection-property p "lock-pid" (emacs-pid)))))) + +(defconst tramp-lock-file-contents-regexp + ;; USER@HOST.PID[:BOOT_TIME] + "\\`\\(.+\\)@\\(.+\\)\\.\\([[:digit:]]+\\)\\(?::\\([[:digit:]]+\\)\\)?\\'" + "The format of a lock file.") + +(defun tramp-handle-file-locked-p (file) + "Like `file-locked-p' for Tramp files." + (when-let ((contents (tramp-get-lock-file file)) + (match (string-match tramp-lock-file-contents-regexp contents))) + (or (and (string-equal (match-string 1 contents) (user-login-name)) + (string-equal (match-string 2 contents) (system-name)) + (string-equal (match-string 3 contents) (tramp-get-lock-pid file))) + (match-string 1 contents)))) + +(defun tramp-handle-lock-file (file) + "Like `lock-file' for Tramp files." + ;; See if this file is visited and has changed on disk since it + ;; was visited. + (catch 'dont-lock + (unless (or (null create-lockfiles) + (eq (file-locked-p file) t)) ;; Locked by me. + (when-let ((contents (tramp-get-lock-file file)) + (match (string-match tramp-lock-file-contents-regexp contents))) + (unless (ask-user-about-lock + file (format + "%s@%s (pid %s)" (match-string 1 contents) + (match-string 2 contents) (match-string 3 contents))) + (throw 'dont-lock nil))) + + (let ((lockname (tramp-make-lock-name file)) + ;; USER@HOST.PID[:BOOT_TIME] + (contents + (format + "%s@%s.%s" (user-login-name) (system-name) + (tramp-get-lock-pid file))) + create-lockfiles signal-hook-function) + (condition-case nil + (make-symbolic-link contents lockname 'ok-if-already-exists) + (error (write-region contents nil lockname))))))) + +(defun tramp-handle-unlock-file (file) + "Like `unlock-file' for Tramp files." + (delete-file (tramp-make-lock-name file))) + (defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix) "Like `load' for Tramp files." (with-parsed-tramp-file-name (expand-file-name file) nil @@ -4355,9 +4427,10 @@ of." (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist)))))))) (defun tramp-handle-write-region - (start end filename &optional append visit _lockname mustbenew) + (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) + (setq filename (expand-file-name filename) + lockname (file-truename (or lockname filename))) (with-parsed-tramp-file-name filename nil (when (and mustbenew (file-exists-p filename) (or (eq mustbenew 'excl) @@ -4366,7 +4439,10 @@ of." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let ((tmpfile (tramp-compat-make-temp-file filename)) + (let ((auto-saving + (string-match-p "^#.+#$" (file-name-nondirectory filename))) + file-locked + (tmpfile (tramp-compat-make-temp-file filename)) (modes (tramp-default-file-modes filename (and (eq mustbenew 'excl) 'nofollow))) (uid (or (tramp-compat-file-attribute-user-id @@ -4375,6 +4451,14 @@ of." (gid (or (tramp-compat-file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer)))) + + ;; Lock file. + (when (and (not auto-saving) (file-remote-p lockname) + (not (eq (file-locked-p lockname) t))) + (setq file-locked t) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'lock-file lockname)) + (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok)) ;; The permissions of the temporary file should be set. If @@ -4404,13 +4488,18 @@ of." (current-time)))) ;; Set the ownership. - (tramp-set-file-uid-gid filename uid gid)) - - ;; The end. - (when (and (null noninteractive) - (or (eq visit t) (null visit) (stringp visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook))) + (tramp-set-file-uid-gid filename uid gid) + + ;; Unlock file. + (when (and file-locked (eq (file-locked-p lockname) t)) + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'unlock-file lockname)) + + ;; The end. + (when (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) + (tramp-message v 0 "Wrote %s" filename)) + (run-hooks 'tramp-handle-write-region-hook)))) ;; This is used in tramp-sh.el and tramp-sudoedit.el. (defconst tramp-stat-marker "/////" diff --git a/src/filelock.c b/src/filelock.c index 446a262a1ce..dcdc635c25e 100644 --- a/src/filelock.c +++ b/src/filelock.c @@ -671,6 +671,16 @@ lock_file (Lisp_Object fn) if (will_dump_p ()) return; + /* If the file name has special constructs in it, + call the corresponding file name handler. */ + Lisp_Object handler; + handler = Ffind_file_name_handler (fn, Qlock_file); + if (!NILP (handler)) + { + call2 (handler, Qlock_file, fn); + return; + } + orig_fn = fn; fn = Fexpand_file_name (fn, Qnil); #ifdef WINDOWSNT @@ -725,6 +735,16 @@ unlock_file_body (Lisp_Object fn) char *lfname; USE_SAFE_ALLOCA; + /* If the file name has special constructs in it, + call the corresponding file name handler. */ + Lisp_Object handler; + handler = Ffind_file_name_handler (fn, Qunlock_file); + if (!NILP (handler)) + { + call2 (handler, Qunlock_file, fn); + return Qnil; + } + Lisp_Object filename = Fexpand_file_name (fn, Qnil); fn = ENCODE_FILE (filename); @@ -784,6 +804,27 @@ unlock_all_files (void) } } +DEFUN ("lock-file", Flock_file, Slock_file, + 0, 1, 0, + doc: /* Lock FILE. +If the option `create-lockfiles' is nil, this does nothing. */) + (Lisp_Object file) +{ + CHECK_STRING (file); + lock_file (file); + return Qnil; +} + +DEFUN ("unlock-file", Funlock_file, Sunlock_file, + 0, 1, 0, + doc: /* Unlock FILE. */) + (Lisp_Object file) +{ + CHECK_STRING (file); + unlock_file (file); + return Qnil; +} + DEFUN ("lock-buffer", Flock_buffer, Slock_buffer, 0, 1, 0, doc: /* Lock FILE, if current buffer is modified. @@ -844,6 +885,15 @@ t if it is locked by you, else a string saying which user has locked it. */) lock_info_type locker; USE_SAFE_ALLOCA; + /* If the file name has special constructs in it, + call the corresponding file name handler. */ + Lisp_Object handler; + handler = Ffind_file_name_handler (filename, Qfile_locked_p); + if (!NILP (handler)) + { + return call2 (handler, Qfile_locked_p, filename); + } + filename = Fexpand_file_name (filename, Qnil); Lisp_Object encoded_filename = ENCODE_FILE (filename); MAKE_LOCK_NAME (lfname, encoded_filename); @@ -876,7 +926,13 @@ The name of the (per-buffer) lockfile is constructed by prepending a Info node `(emacs)Interlocking'. */); create_lockfiles = true; - defsubr (&Sunlock_buffer); + DEFSYM (Qlock_file, "lock-file"); + DEFSYM (Qunlock_file, "unlock-file"); + DEFSYM (Qfile_locked_p, "file-locked-p"); + + defsubr (&Slock_file); + defsubr (&Sunlock_file); defsubr (&Slock_buffer); + defsubr (&Sunlock_buffer); defsubr (&Sfile_locked_p); } diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index ca1163bb775..aac1b13bd0e 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -856,7 +856,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (tramp-archive-cleanup-hash)))) ;; The functions were introduced in Emacs 26.1. -(ert-deftest tramp-archive-test39-make-nearby-temp-file () +(ert-deftest tramp-archive-test40-make-nearby-temp-file () "Check `make-nearby-temp-file' and `temporary-file-directory'." (skip-unless tramp-archive-enabled) ;; Since Emacs 26.1. @@ -893,7 +893,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (delete-directory tmp-file) (should-not (file-exists-p tmp-file)))) -(ert-deftest tramp-archive-test42-file-system-info () +(ert-deftest tramp-archive-test43-file-system-info () "Check that `file-system-info' returns proper values." (skip-unless tramp-archive-enabled) ;; Since Emacs 27.1. diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 7f894448a67..0e70f8e1d23 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -33,7 +33,7 @@ ;; remote host, set this environment variable to "/dev/null" or ;; whatever is appropriate on your system. -;; For slow remote connections, `tramp-test43-asynchronous-requests' +;; For slow remote connections, `tramp-test44-asynchronous-requests' ;; might be too heavy. Setting $REMOTE_PARALLEL_PROCESSES to a proper ;; value less than 10 could help. @@ -122,6 +122,7 @@ (setq auth-source-save-behavior nil password-cache-expiry nil remote-file-name-inhibit-cache nil + create-lockfiles nil tramp-cache-read-persistent-data t ;; For auth-sources. tramp-copy-size-limit nil tramp-persistency-file-name nil @@ -2463,6 +2464,8 @@ This checks also `file-name-as-directory', `file-name-directory', "^\\'") tramp--test-messages)))))))) + ;; We do not test lockname here. See `tramp-test39-lock-file'. + ;; Do not overwrite if excluded. (cl-letf (((symbol-function #'y-or-n-p) #'tramp--test-always) ;; Ange-FTP. @@ -2833,8 +2836,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (delete-directory tmp-name1 nil 'trash) ;; tramp-rclone.el and tramp-sshfs.el call the local ;; `delete-directory'. This raises another error. - :type (if (or (tramp--test-rclone-p) (tramp--test-sshfs-p)) - 'error 'file-error)) + :type (if (tramp--test-fuse-p) 'error 'file-error)) (delete-directory tmp-name1 'recursive 'trash) (should-not (file-directory-p tmp-name1)) (should @@ -5741,8 +5743,77 @@ Use direct async.") (ignore-errors (delete-file tmp-name1)) (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password))))) +;; The functions were introduced in Emacs 28.1. +(ert-deftest tramp-test39-lock-file () + "Check `lock-file', `unlock-file' and `file-locked-p'." + (skip-unless (tramp--test-enabled)) + (skip-unless (not (tramp--test-ange-ftp-p))) + ;; Since Emacs 28.1. + (skip-unless (and (fboundp 'lock-file) (fboundp 'unlock-file))) + + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (let ((tmp-name (tramp--test-make-temp-name nil quoted)) + (remote-file-name-inhibit-cache t) + (create-lockfiles t) + (inhibit-message t) + ;; tramp-rclone.el and tramp-sshfs.el cache the mounted files. + (tramp-cleanup-connection-hook + (append + (and (tramp--test-fuse-p) '(tramp-fuse-unmount)) + tramp-cleanup-connection-hook)) + noninteractive) + + (unwind-protect + (progn + ;; A simple file lock. + (should-not (file-locked-p tmp-name)) + (lock-file tmp-name) + (should (eq (file-locked-p tmp-name) t)) + + ;; If it is locked already, nothing changes. + (lock-file tmp-name) + (should (eq (file-locked-p tmp-name) t)) + + ;; A new connection changes process id, and also the + ;; lockname contents. + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) + (should (stringp (file-locked-p tmp-name))) + + ;; Steal the file lock. + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'read-char) (lambda (&rest _args) ?s))) + (lock-file tmp-name)) + (should (eq (file-locked-p tmp-name) t)) + + ;; Ignore the file lock. + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'read-char) (lambda (&rest _args) ?p))) + (lock-file tmp-name)) + (should (stringp (file-locked-p tmp-name))) + + ;; Quit the file lock machinery. + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'read-char) (lambda (&rest _args) ?q))) + (should-error (lock-file tmp-name) :type 'file-locked)) + (should (stringp (file-locked-p tmp-name))) + + ;; The same for `write-region'. + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'read-char) (lambda (&rest _args) ?q))) + (should-error (write-region "foo" nil tmp-name) :type 'file-locked) + (should-error + (write-region "foo" nil tmp-name nil nil tmp-name) + :type 'file-locked)) + (should (stringp (file-locked-p tmp-name))) + (should-not (file-exists-p tmp-name))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name)) + (unlock-file tmp-name) + (should-not (file-locked-p tmp-name)))))) + ;; The functions were introduced in Emacs 26.1. -(ert-deftest tramp-test39-make-nearby-temp-file () +(ert-deftest tramp-test40-make-nearby-temp-file () "Check `make-nearby-temp-file' and `temporary-file-directory'." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-ange-ftp-p))) @@ -5825,6 +5896,10 @@ This does not support globbing characters in file names (yet)." (string-match-p "ftp$" (file-remote-p tramp-test-temporary-file-directory 'method))) +(defun tramp--test-fuse-p () + "Check, whether an FUSE file system isused." + (or (tramp--test-rclone-p) (tramp--test-sshfs-p))) + (defun tramp--test-gdrive-p () "Check, whether the gdrive method is used." (string-equal @@ -6115,7 +6190,7 @@ This requires restrictions of file name syntax." (ignore-errors (delete-directory tmp-name2 'recursive)))))) (defun tramp--test-special-characters () - "Perform the test in `tramp-test40-special-characters*'." + "Perform the test in `tramp-test41-special-characters*'." ;; Newlines, slashes and backslashes in file names are not ;; supported. So we don't test. And we don't test the tab ;; character on Windows or Cygwin, because the backslash is @@ -6173,7 +6248,7 @@ This requires restrictions of file name syntax." files (list (mapconcat #'identity files "")))))) ;; These tests are inspired by Bug#17238. -(ert-deftest tramp-test40-special-characters () +(ert-deftest tramp-test41-special-characters () "Check special characters in file names." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-rsync-p))) @@ -6181,7 +6256,7 @@ This requires restrictions of file name syntax." (tramp--test-special-characters)) -(ert-deftest tramp-test40-special-characters-with-stat () +(ert-deftest tramp-test41-special-characters-with-stat () "Check special characters in file names. Use the `stat' command." :tags '(:expensive-test) @@ -6199,7 +6274,7 @@ Use the `stat' command." tramp-connection-properties))) (tramp--test-special-characters))) -(ert-deftest tramp-test40-special-characters-with-perl () +(ert-deftest tramp-test41-special-characters-with-perl () "Check special characters in file names. Use the `perl' command." :tags '(:expensive-test) @@ -6220,7 +6295,7 @@ Use the `perl' command." tramp-connection-properties))) (tramp--test-special-characters))) -(ert-deftest tramp-test40-special-characters-with-ls () +(ert-deftest tramp-test41-special-characters-with-ls () "Check special characters in file names. Use the `ls' command." :tags '(:expensive-test) @@ -6241,7 +6316,7 @@ Use the `ls' command." (tramp--test-special-characters))) (defun tramp--test-utf8 () - "Perform the test in `tramp-test41-utf8*'." + "Perform the test in `tramp-test42-utf8*'." (let* ((utf8 (if (and (eq system-type 'darwin) (memq 'utf-8-hfs (coding-system-list))) 'utf-8-hfs 'utf-8)) @@ -6287,7 +6362,7 @@ Use the `ls' command." (replace-regexp-in-string "[ \t\n/.?]" "" x))) language-info-alist))))))) -(ert-deftest tramp-test41-utf8 () +(ert-deftest tramp-test42-utf8 () "Check UTF8 encoding in file names and file contents." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-docker-p))) @@ -6300,7 +6375,7 @@ Use the `ls' command." (tramp--test-utf8)) -(ert-deftest tramp-test41-utf8-with-stat () +(ert-deftest tramp-test42-utf8-with-stat () "Check UTF8 encoding in file names and file contents. Use the `stat' command." :tags '(:expensive-test) @@ -6322,7 +6397,7 @@ Use the `stat' command." tramp-connection-properties))) (tramp--test-utf8))) -(ert-deftest tramp-test41-utf8-with-perl () +(ert-deftest tramp-test42-utf8-with-perl () "Check UTF8 encoding in file names and file contents. Use the `perl' command." :tags '(:expensive-test) @@ -6347,7 +6422,7 @@ Use the `perl' command." tramp-connection-properties))) (tramp--test-utf8))) -(ert-deftest tramp-test41-utf8-with-ls () +(ert-deftest tramp-test42-utf8-with-ls () "Check UTF8 encoding in file names and file contents. Use the `ls' command." :tags '(:expensive-test) @@ -6371,7 +6446,7 @@ Use the `ls' command." tramp-connection-properties))) (tramp--test-utf8))) -(ert-deftest tramp-test42-file-system-info () +(ert-deftest tramp-test43-file-system-info () "Check that `file-system-info' returns proper values." (skip-unless (tramp--test-enabled)) ;; Since Emacs 27.1. @@ -6388,11 +6463,11 @@ Use the `ls' command." (numberp (nth 1 fsi)) (numberp (nth 2 fsi)))))) -;; `tramp-test43-asynchronous-requests' could be blocked. So we set a +;; `tramp-test44-asynchronous-requests' could be blocked. So we set a ;; timeout of 300 seconds, and we send a SIGUSR1 signal after 300 ;; seconds. Similar check is performed in the timer function. (defconst tramp--test-asynchronous-requests-timeout 300 - "Timeout for `tramp-test43-asynchronous-requests'.") + "Timeout for `tramp-test44-asynchronous-requests'.") (defmacro tramp--test-with-proper-process-name-and-buffer (proc &rest body) "Set \"process-name\" and \"process-buffer\" connection properties. @@ -6428,7 +6503,7 @@ This is needed in timer functions as well as process filters and sentinels." (tramp-flush-connection-property v "process-buffer"))))) ;; This test is inspired by Bug#16928. -(ert-deftest tramp-test43-asynchronous-requests () +(ert-deftest tramp-test44-asynchronous-requests () "Check parallel asynchronous requests. Such requests could arrive from timers, process filters and process sentinels. They shall not disturb each other." @@ -6628,11 +6703,11 @@ process sentinels. They shall not disturb each other." (ignore-errors (cancel-timer timer)) (ignore-errors (delete-directory tmp-name 'recursive)))))) -;; (tramp--test--deftest-direct-async-process tramp-test43-asynchronous-requests +;; (tramp--test--deftest-direct-async-process tramp-test44-asynchronous-requests ;; "Check parallel direct asynchronous requests." 'unstable) ;; This test is inspired by Bug#29163. -(ert-deftest tramp-test44-auto-load () +(ert-deftest tramp-test45-auto-load () "Check that Tramp autoloads properly." ;; If we use another syntax but `default', Tramp is already loaded ;; due to the `tramp-change-syntax' call. @@ -6657,7 +6732,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test44-delay-load () +(ert-deftest tramp-test45-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. @@ -6690,7 +6765,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument (format code tm))))))))) -(ert-deftest tramp-test44-recursive-load () +(ert-deftest tramp-test45-recursive-load () "Check that Tramp does not fail due to recursive load." (skip-unless (tramp--test-enabled)) @@ -6714,7 +6789,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code)))))))) -(ert-deftest tramp-test44-remote-load-path () +(ert-deftest tramp-test45-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. @@ -6743,7 +6818,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test45-unload () +(ert-deftest tramp-test46-unload () "Check that Tramp and its subpackages unload completely. Since it unloads Tramp, it shall be the last test to run." :tags '(:expensive-test) @@ -6826,7 +6901,7 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; * Implement `tramp-test31-interrupt-process' for `adb', `sshfs' and ;; for direct async processes. ;; * Check, why direct async processes do not work for -;; `tramp-test43-asynchronous-requests'. +;; `tramp-test44-asynchronous-requests'. (provide 'tramp-tests) -- cgit v1.2.3 From 6d580b00e48e567ac92645e2d120769475d196ad Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Thu, 8 Jul 2021 07:48:40 +0200 Subject: Some further adaptions wrt Tramp file name locks * lisp/files.el (files--transform-file-name): Rename from `auto-save--transform-file-name'. Wrap with `save-match-data'. (make-auto-save-file-name): Use it. (make-lock-file-name): Use it. Call file name handler. * lisp/net/tramp.el (tramp-handle-write-region): * lisp/net/tramp-adb.el (tramp-adb-handle-write-region): * lisp/net/tramp-sh.el (tramp-sh-handle-write-region): * lisp/net/tramp-smb.el (tramp-smb-handle-write-region): Suppress file lock for temporary file. * lisp/net/tramp-compat.el (tramp-compat-make-lock-file-name): New defalias. * lisp/net/tramp.el (tramp-get-lock-file) (tramp-handle-lock-file, tramp-handle-unlock-file): Use it. (tramp-make-lock-name): Remove. * test/lisp/filenotify-tests.el (file-notify-test03-events-remote): Tag it :unstable temporarily. --- lisp/files.el | 122 +++++++++++++++++++++--------------------- lisp/net/tramp-adb.el | 3 +- lisp/net/tramp-compat.el | 10 ++++ lisp/net/tramp-sh.el | 7 ++- lisp/net/tramp-smb.el | 3 +- lisp/net/tramp.el | 15 +++--- test/lisp/filenotify-tests.el | 2 +- 7 files changed, 87 insertions(+), 75 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/files.el b/lisp/files.el index c1377320b35..da8598f1502 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -6679,12 +6679,12 @@ Does not consider `auto-save-visited-file-name' as that variable is checked before calling this function. See also `auto-save-file-name-p'." (if buffer-file-name - (let ((handler (find-file-name-handler buffer-file-name - 'make-auto-save-file-name))) + (let ((handler (find-file-name-handler + buffer-file-name 'make-auto-save-file-name))) (if handler (funcall handler 'make-auto-save-file-name) - (auto-save--transform-file-name buffer-file-name - auto-save-file-name-transforms + (files--transform-file-name + buffer-file-name auto-save-file-name-transforms "#" "#"))) ;; Deal with buffers that don't have any associated files. (Mail ;; mode tends to create a good number of these.) @@ -6735,73 +6735,73 @@ See also `auto-save-file-name-p'." (file-error nil)) file-name))) -(defun auto-save--transform-file-name (filename transforms - prefix suffix) +(defun files--transform-file-name (filename transforms prefix suffix) "Transform FILENAME according to TRANSFORMS. See `auto-save-file-name-transforms' for the format of TRANSFORMS. PREFIX is prepended to the non-directory portion of the resulting file name, and SUFFIX is appended." - (let (result uniq) - ;; Apply user-specified translations - ;; to the file name. - (while (and transforms (not result)) - (if (string-match (car (car transforms)) filename) - (setq result (replace-match (cadr (car transforms)) t nil - filename) - uniq (car (cddr (car transforms))))) - (setq transforms (cdr transforms))) - (when result - (setq filename - (cond - ((memq uniq (secure-hash-algorithms)) - (concat - (file-name-directory result) - (secure-hash uniq filename))) - (uniq - (concat - (file-name-directory result) - (subst-char-in-string - ?/ ?! - (replace-regexp-in-string - "!" "!!" filename)))) - (t result)))) - (setq result - (if (and (eq system-type 'ms-dos) - (not (msdos-long-file-names))) - ;; We truncate the file name to DOS 8+3 limits - ;; before doing anything else, because the regexp - ;; passed to string-match below cannot handle - ;; extensions longer than 3 characters, multiple - ;; dots, and other atrocities. - (let ((fn (dos-8+3-filename - (file-name-nondirectory buffer-file-name)))) - (string-match - "\\`\\([^.]+\\)\\(\\.\\(..?\\)?.?\\|\\)\\'" - fn) - (concat (file-name-directory buffer-file-name) - prefix (match-string 1 fn) - "." (match-string 3 fn) suffix)) - (concat (file-name-directory filename) - prefix - (file-name-nondirectory filename) - suffix))) - ;; Make sure auto-save file names don't contain characters - ;; invalid for the underlying filesystem. - (expand-file-name - (if (and (memq system-type '(ms-dos windows-nt cygwin)) - ;; Don't modify remote filenames - (not (file-remote-p result))) - (convert-standard-filename result) - result)))) + (save-match-data + (let (result uniq) + ;; Apply user-specified translations to the file name. + (while (and transforms (not result)) + (if (string-match (car (car transforms)) filename) + (setq result (replace-match (cadr (car transforms)) t nil + filename) + uniq (car (cddr (car transforms))))) + (setq transforms (cdr transforms))) + (when result + (setq filename + (cond + ((memq uniq (secure-hash-algorithms)) + (concat + (file-name-directory result) + (secure-hash uniq filename))) + (uniq + (concat + (file-name-directory result) + (subst-char-in-string + ?/ ?! + (replace-regexp-in-string + "!" "!!" filename)))) + (t result)))) + (setq result + (if (and (eq system-type 'ms-dos) + (not (msdos-long-file-names))) + ;; We truncate the file name to DOS 8+3 limits before + ;; doing anything else, because the regexp passed to + ;; string-match below cannot handle extensions longer + ;; than 3 characters, multiple dots, and other + ;; atrocities. + (let ((fn (dos-8+3-filename + (file-name-nondirectory buffer-file-name)))) + (string-match + "\\`\\([^.]+\\)\\(\\.\\(..?\\)?.?\\|\\)\\'" + fn) + (concat (file-name-directory buffer-file-name) + prefix (match-string 1 fn) + "." (match-string 3 fn) suffix)) + (concat (file-name-directory filename) + prefix + (file-name-nondirectory filename) + suffix))) + ;; Make sure auto-save file names don't contain characters + ;; invalid for the underlying filesystem. + (expand-file-name + (if (and (memq system-type '(ms-dos windows-nt cygwin)) + ;; Don't modify remote filenames + (not (file-remote-p result))) + (convert-standard-filename result) + result))))) (defun make-lock-file-name (filename) "Make a lock file name for FILENAME. By default, this just prepends \".*\" to the non-directory part of FILENAME, but the transforms in `lock-file-name-transforms' are done first." - (save-match-data - (auto-save--transform-file-name - filename lock-file-name-transforms ".#" ""))) + (let ((handler (find-file-name-handler filename 'make-lock-file-name))) + (if handler + (funcall handler 'make-lock-file-name filename) + (files--transform-file-name filename lock-file-name-transforms ".#" "")))) (defun auto-save-file-name-p (filename) "Return non-nil if FILENAME can be yielded by `make-auto-save-file-name'. diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 9c1c8aca1ca..2bd13671458 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -564,7 +564,8 @@ But handle the case, if the \"test\" command is not available." (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok) (set-file-modes tmpfile (logior (or (file-modes tmpfile) 0) #o0600))) - (write-region start end tmpfile append 'no-message) + (let (create-lockfiles) + (write-region start end tmpfile append 'no-message)) (with-tramp-progress-reporter v 3 (format-message "Moving tmp file `%s' to `%s'" tmpfile filename) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 54cfb6fb4a4..9d5e5f787b6 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -353,6 +353,16 @@ A nil value for either argument stands for the current time." (lambda (fromstring tostring instring) (replace-regexp-in-string (regexp-quote fromstring) tostring instring)))) +;; Function `make-lock-file-name' is new in Emacs 28.1. +(defalias 'tramp-compat-make-lock-file-name + (if (fboundp 'make-lock-file-name) + #'make-lock-file-name + (lambda (filename) + (expand-file-name + (concat + ".#" (file-name-nondirectory filename)) + (file-name-directory filename))))) + (dolist (elt (all-completions "tramp-compat-" obarray 'functionp)) (put (intern elt) 'tramp-suppress-trace t)) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 11037227790..c65800bb0ea 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -3274,7 +3274,9 @@ implementation will be used." (or (file-directory-p localname) (file-writable-p localname))))) ;; Short track: if we are on the local host, we can run directly. - (write-region start end localname append 'no-message) + (write-region + start end localname append 'no-message + (and lockname (file-local-name lockname))) (let* ((modes (tramp-default-file-modes filename (and (eq mustbenew 'excl) 'nofollow))) @@ -3308,7 +3310,8 @@ implementation will be used." ;; on. We must ensure that `file-coding-system-alist' ;; matches `tmpfile'. (let ((file-coding-system-alist - (tramp-find-file-name-coding-system-alist filename tmpfile))) + (tramp-find-file-name-coding-system-alist filename tmpfile)) + create-lockfiles) (condition-case err (write-region start end tmpfile append 'no-message) ((error quit) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 500245b3e19..01192db920a 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -1606,7 +1606,8 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." ;; We say `no-message' here because we don't want the visited file ;; modtime data to be clobbered from the temp file. We call ;; `set-visited-file-modtime' ourselves later on. - (write-region start end tmpfile append 'no-message) + (let (create-lockfiles) + (write-region start end tmpfile append 'no-message)) (with-tramp-progress-reporter v 3 (format "Moving tmp file %s to %s" tmpfile filename) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 37d60e854f2..e9e08265fed 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3818,15 +3818,10 @@ User is always nil." ;; Result. (cons (expand-file-name filename) (cdr result))))) -(defun tramp-make-lock-name (file) - "Implement MAKE_LOCK_NAME of filelock.c." - (expand-file-name - (concat ".#" (file-name-nondirectory file)) (file-name-directory file))) - (defun tramp-get-lock-file (file) "Read lockfile of FILE. Return nil when there is no lockfile" - (let ((lockname (tramp-make-lock-name file))) + (let ((lockname (tramp-compat-make-lock-file-name file))) (or (file-symlink-p lockname) (and (file-readable-p lockname) (with-temp-buffer @@ -3873,7 +3868,7 @@ Return nil when there is no lockfile" (match-string 2 contents) (match-string 3 contents))) (throw 'dont-lock nil))) - (let ((lockname (tramp-make-lock-name file)) + (let ((lockname (tramp-compat-make-lock-file-name file)) ;; USER@HOST.PID[:BOOT_TIME] (contents (format @@ -3886,7 +3881,8 @@ Return nil when there is no lockfile" (defun tramp-handle-unlock-file (file) "Like `unlock-file' for Tramp files." - (delete-file (tramp-make-lock-name file))) + (ignore-errors + (delete-file (tramp-compat-make-lock-file-name file)))) (defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix) "Like `load' for Tramp files." @@ -4470,7 +4466,8 @@ of." ;; We say `no-message' here because we don't want the visited file ;; modtime data to be clobbered from the temp file. We call ;; `set-visited-file-modtime' ourselves later on. - (write-region start end tmpfile append 'no-message) + (let (create-lockfiles) + (write-region start end tmpfile append 'no-message)) (condition-case nil (rename-file tmpfile filename 'ok-if-already-exists) (error diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index e0fa66a5d99..6125069c6b3 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -927,7 +927,7 @@ delivered." (file-notify--test-cleanup))) (file-notify--deftest-remote file-notify-test03-events - "Check file creation/change/removal notifications for remote files.") + "Check file creation/change/removal notifications for remote files." t) (require 'autorevert) (setq auto-revert-notify-exclude-dir-regexp "nothing-to-be-excluded" -- cgit v1.2.3 From a6a92e3ac55b4a07f3b91dffecc28a89c2b5dbf2 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Thu, 8 Jul 2021 21:13:40 +0200 Subject: Code cleanup wrt file locks * lisp/files.el (make-lock-file-name): Fix docstring. * lisp/net/tramp-adb.el (tramp-adb-file-name-handler-alist): * lisp/net/tramp-archive.el (tramp-archive-file-name-handler-alist): * lisp/net/tramp-crypt.el (tramp-crypt-file-name-handler-alist): * lisp/net/tramp-gvfs.el (tramp-gvfs-file-name-handler-alist): * lisp/net/tramp-rclone.el (tramp-rclone-file-name-handler-alist): * lisp/net/tramp-sh.el (tramp-sh-file-name-handler-alist): * lisp/net/tramp-smb.el (tramp-smb-file-name-handler-alist): * lisp/net/tramp-sshfs.el (tramp-sshfs-file-name-handler-alist): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-file-name-handler-alist): Add `make-lock-file-name'. * lisp/net/tramp.el (tramp-file-name-for-operation): Add `make-lock-file-name'. (tramp-handle-unlock-file): Call `userlock--handle-unlock-error' in case of error. * src/buffer.c (Frestore_buffer_modified_p): * src/editfns.c (Freplace_buffer_contents): * src/fileio.c (Finsert_file_contents, write_region): Call Funlock_file. * src/filelock.c (unlock_file): Rename from unlock_file_body. Remove the other declarations of unlock_file. Move file name handler check to ... (Funlock_file): ... here. Adapt argument numbers. Call unlock_file wrapped by internal_condition_case. (Flock_file): Adapt argument numbers. (unlock_all_files, Funlock_buffer, unlock_buffer): Call Funlock_file. * src/lisp.h (unlock_file): Remove. --- lisp/files.el | 2 +- lisp/net/tramp-adb.el | 1 + lisp/net/tramp-archive.el | 1 + lisp/net/tramp-crypt.el | 1 + lisp/net/tramp-gvfs.el | 1 + lisp/net/tramp-rclone.el | 1 + lisp/net/tramp-sh.el | 1 + lisp/net/tramp-smb.el | 1 + lisp/net/tramp-sshfs.el | 1 + lisp/net/tramp-sudoedit.el | 1 + lisp/net/tramp.el | 7 +++--- lisp/userlock.el | 2 +- src/buffer.c | 2 +- src/editfns.c | 2 +- src/fileio.c | 16 ++++++------- src/filelock.c | 58 ++++++++++++++++++++-------------------------- src/lisp.h | 1 - 17 files changed, 50 insertions(+), 49 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/files.el b/lisp/files.el index da8598f1502..0dfcab8f89b 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -6795,7 +6795,7 @@ the resulting file name, and SUFFIX is appended." (defun make-lock-file-name (filename) "Make a lock file name for FILENAME. -By default, this just prepends \".*\" to the non-directory part +By default, this just prepends \".#\" to the non-directory part of FILENAME, but the transforms in `lock-file-name-transforms' are done first." (let ((handler (find-file-name-handler filename 'make-lock-file-name))) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 2bd13671458..788548badec 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -164,6 +164,7 @@ It is used for TCP/IP devices." (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-adb-handle-make-directory) (make-directory-internal . ignore) + ;; `make-lock-file-name' performed by default handler. (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-adb-handle-make-process) (make-symbolic-link . tramp-handle-make-symbolic-link) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index a6f479bcbcb..67798e892ab 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -267,6 +267,7 @@ It must be supported by libarchive(3).") (make-auto-save-file-name . ignore) (make-directory . tramp-archive-handle-not-implemented) (make-directory-internal . tramp-archive-handle-not-implemented) + (make-lock-file-name . ignore) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-archive-handle-not-implemented) diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 31988bc9ef9..1b77fea7e18 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -213,6 +213,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-crypt-handle-make-directory) (make-directory-internal . ignore) + ;; `make-lock-file-name' performed by default handler. (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index e784ea83ef2..04de5defb37 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -805,6 +805,7 @@ It has been changed in GVFS 1.14.") (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-gvfs-handle-make-directory) (make-directory-internal . ignore) + ;; `make-lock-file-name' performed by default handler. (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 6c710dd0b1b..473fa8a8f0e 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -127,6 +127,7 @@ (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-fuse-handle-make-directory) (make-directory-internal . ignore) + ;; `make-lock-file-name' performed by default handler. (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index c65800bb0ea..404e9aff7a2 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -993,6 +993,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (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-lock-file-name' performed by default handler. (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-sh-handle-make-process) (make-symbolic-link . tramp-sh-handle-make-symbolic-link) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 01192db920a..87f62391e34 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -278,6 +278,7 @@ See `tramp-actions-before-shell' for more info.") (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-smb-handle-make-directory) (make-directory-internal . tramp-smb-handle-make-directory-internal) + ;; `make-lock-file-name' performed by default handler. (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-smb-handle-make-symbolic-link) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index babd770be9b..3a3703b267d 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -127,6 +127,7 @@ (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-fuse-handle-make-directory) (make-directory-internal . ignore) + ;; `make-lock-file-name' performed by default handler. (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-handle-make-process) (make-symbolic-link . tramp-handle-make-symbolic-link) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index aa6f85ec6ef..d68a5c1adf4 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -120,6 +120,7 @@ See `tramp-actions-before-shell' for more info.") (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-sudoedit-handle-make-directory) (make-directory-internal . ignore) + ;; `make-lock-file-name' performed by default handler. (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-sudoedit-handle-make-symbolic-link) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index e9e08265fed..7578d6fe308 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2456,7 +2456,7 @@ Must be handled by the callers." ;; Emacs 27+ only. file-system-info ;; Emacs 28+ only. - file-locked-p lock-file unlock-file + file-locked-p lock-file make-lock-file-name unlock-file ;; Tramp internal magic file name function. tramp-set-file-uid-gid)) (if (file-name-absolute-p (nth 0 args)) @@ -3881,8 +3881,9 @@ Return nil when there is no lockfile" (defun tramp-handle-unlock-file (file) "Like `unlock-file' for Tramp files." - (ignore-errors - (delete-file (tramp-compat-make-lock-file-name file)))) + (condition-case err + (delete-file (tramp-compat-make-lock-file-name file)) + (error (userlock--handle-unlock-error err)))) (defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix) "Like `load' for Tramp files." diff --git a/lisp/userlock.el b/lisp/userlock.el index 4a758153189..38aaf6aec23 100644 --- a/lisp/userlock.el +++ b/lisp/userlock.el @@ -230,7 +230,7 @@ to get the latest version of the file, then make the change again." (display-warning '(unlock-file) ;; There is no need to explain that this is an unlock error because - ;; ERR is a `file-error' condition, which explains this. + ;; ERROR is a `file-error' condition, which explains this. (message "%s, ignored" (error-message-string error)) :warning)) diff --git a/src/buffer.c b/src/buffer.c index 565577e75ae..3cd47fede36 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -1451,7 +1451,7 @@ state of the current buffer. Use with care. */) if (!already && !NILP (flag)) lock_file (fn); else if (already && NILP (flag)) - unlock_file (fn); + Funlock_file (fn); } } diff --git a/src/editfns.c b/src/editfns.c index aa0f46fea04..8ab17ebc9f9 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -2137,7 +2137,7 @@ nil. */) the file now. */ if (SAVE_MODIFF == MODIFF && STRINGP (BVAR (a, file_truename))) - unlock_file (BVAR (a, file_truename)); + Funlock_file (BVAR (a, file_truename)); } return Qt; diff --git a/src/fileio.c b/src/fileio.c index c0d1a5084a0..30e6caf7ea5 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -4544,7 +4544,7 @@ by calling `format-decode', which see. */) if (inserted == 0) { if (we_locked_file) - unlock_file (BVAR (current_buffer, file_truename)); + Funlock_file (BVAR (current_buffer, file_truename)); Vdeactivate_mark = old_Vdeactivate_mark; } else @@ -4706,8 +4706,8 @@ by calling `format-decode', which see. */) if (NILP (handler)) { if (!NILP (BVAR (current_buffer, file_truename))) - unlock_file (BVAR (current_buffer, file_truename)); - unlock_file (filename); + Funlock_file (BVAR (current_buffer, file_truename)); + Funlock_file (filename); } if (not_regular) xsignal2 (Qfile_error, @@ -5193,7 +5193,7 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename, { int open_errno = errno; if (file_locked) - unlock_file (lockname); + Funlock_file (lockname); report_file_errno ("Opening output file", filename, open_errno); } @@ -5208,7 +5208,7 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename, { int lseek_errno = errno; if (file_locked) - unlock_file (lockname); + Funlock_file (lockname); report_file_errno ("Lseek error", filename, lseek_errno); } } @@ -5345,7 +5345,7 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename, unbind_to (count, Qnil); if (file_locked) - unlock_file (lockname); + Funlock_file (lockname); /* Do this before reporting IO error to avoid a "file has changed on disk" warning on @@ -5370,14 +5370,14 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename, bset_filename (current_buffer, visit_file); update_mode_lines = 14; if (auto_saving_into_visited_file) - unlock_file (lockname); + Funlock_file (lockname); } else if (quietly) { if (auto_saving_into_visited_file) { SAVE_MODIFF = MODIFF; - unlock_file (lockname); + Funlock_file (lockname); } return Qnil; diff --git a/src/filelock.c b/src/filelock.c index 20916ace50d..9f1968f07de 100644 --- a/src/filelock.c +++ b/src/filelock.c @@ -657,6 +657,8 @@ lock_file (Lisp_Object fn) if (will_dump_p ()) return; + /* If the file name has special constructs in it, + call the corresponding file name handler. */ Lisp_Object handler; handler = Ffind_file_name_handler (fn, Qlock_file); if (!NILP (handler)) @@ -705,20 +707,10 @@ lock_file (Lisp_Object fn) } static Lisp_Object -unlock_file_body (Lisp_Object fn) +unlock_file (Lisp_Object fn) { char *lfname; - /* If the file name has special constructs in it, - call the corresponding file name handler. */ - Lisp_Object handler; - handler = Ffind_file_name_handler (fn, Qunlock_file); - if (!NILP (handler)) - { - call2 (handler, Qunlock_file, fn); - return Qnil; - } - Lisp_Object lock_filename = make_lock_file_name (fn); if (NILP (lock_filename)) return Qnil; @@ -740,26 +732,12 @@ unlock_file_handle_error (Lisp_Object err) return Qnil; } -void -unlock_file (Lisp_Object fn) -{ - internal_condition_case_1 (unlock_file_body, - fn, - list1(Qfile_error), - unlock_file_handle_error); -} - #else /* MSDOS */ void lock_file (Lisp_Object fn) { } -void -unlock_file (Lisp_Object fn) -{ -} - #endif /* MSDOS */ void @@ -773,12 +751,11 @@ unlock_all_files (void) b = XBUFFER (buf); if (STRINGP (BVAR (b, file_truename)) && BUF_SAVE_MODIFF (b) < BUF_MODIFF (b)) - unlock_file (BVAR (b, file_truename)); + Funlock_file (BVAR (b, file_truename)); } } -DEFUN ("lock-file", Flock_file, Slock_file, - 0, 1, 0, +DEFUN ("lock-file", Flock_file, Slock_file, 1, 1, 0, doc: /* Lock FILE. If the option `create-lockfiles' is nil, this does nothing. */) (Lisp_Object file) @@ -788,13 +765,28 @@ If the option `create-lockfiles' is nil, this does nothing. */) return Qnil; } -DEFUN ("unlock-file", Funlock_file, Sunlock_file, - 0, 1, 0, +DEFUN ("unlock-file", Funlock_file, Sunlock_file, 1, 1, 0, doc: /* Unlock FILE. */) (Lisp_Object file) { +#ifndef MSDOS CHECK_STRING (file); - unlock_file (file); + + /* If the file name has special constructs in it, + call the corresponding file name handler. */ + Lisp_Object handler; + handler = Ffind_file_name_handler (file, Qunlock_file); + if (!NILP (handler)) + { + call2 (handler, Qunlock_file, file); + return Qnil; + } + + internal_condition_case_1 (unlock_file, + file, + list1 (Qfile_error), + unlock_file_handle_error); +#endif /* MSDOS */ return Qnil; } @@ -829,7 +821,7 @@ error did not occur. */) { if (SAVE_MODIFF < MODIFF && STRINGP (BVAR (current_buffer, file_truename))) - unlock_file (BVAR (current_buffer, file_truename)); + Funlock_file (BVAR (current_buffer, file_truename)); return Qnil; } @@ -840,7 +832,7 @@ unlock_buffer (struct buffer *buffer) { if (BUF_SAVE_MODIFF (buffer) < BUF_MODIFF (buffer) && STRINGP (BVAR (buffer, file_truename))) - unlock_file (BVAR (buffer, file_truename)); + Funlock_file (BVAR (buffer, file_truename)); } DEFUN ("file-locked-p", Ffile_locked_p, Sfile_locked_p, 1, 1, 0, diff --git a/src/lisp.h b/src/lisp.h index 4fb89236788..ce4b80a27ec 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4622,7 +4622,6 @@ extern void syms_of_sysdep (void); /* Defined in filelock.c. */ extern void lock_file (Lisp_Object); -extern void unlock_file (Lisp_Object); extern void unlock_all_files (void); extern void unlock_buffer (struct buffer *); extern void syms_of_filelock (void); -- cgit v1.2.3 From ad6ad1646d7b3e9fac8198dc734d500ae0d40d78 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sun, 11 Jul 2021 17:41:33 +0200 Subject: Use `auto-save-file-name-p' in tramp-*-write-region * lisp/net/tramp.el (tramp-handle-write-region): * lisp/net/tramp-adb.el (tramp-adb-handle-write-region): * lisp/net/tramp-sh.el (tramp-sh-handle-write-region): * lisp/net/tramp-smb.el (tramp-smb-handle-write-region): * lisp/net/tramp-sshfs.el (tramp-sshfs-handle-write-region): Use `auto-save-file-name-p'. --- lisp/net/tramp-adb.el | 11 +++++------ lisp/net/tramp-sh.el | 19 +++++++------------ lisp/net/tramp-smb.el | 7 +++---- lisp/net/tramp-sshfs.el | 7 +++---- lisp/net/tramp.el | 7 +++---- 5 files changed, 21 insertions(+), 30 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 788548badec..63fd5eb06a3 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -549,14 +549,13 @@ But handle the case, if the \"test\" command is not available." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let* ((auto-saving - (string-match-p "^#.+#$" (file-name-nondirectory filename))) - file-locked - (curbuf (current-buffer)) - (tmpfile (tramp-compat-make-temp-file filename))) + (let (file-locked + (curbuf (current-buffer)) + (tmpfile (tramp-compat-make-temp-file filename))) ;; Lock file. - (when (and (not auto-saving) (file-remote-p lockname) + (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) + (file-remote-p lockname) (not (eq (file-locked-p lockname) t))) (setq file-locked t) ;; `lock-file' exists since Emacs 28.1. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 404e9aff7a2..e5929bd366a 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -3249,9 +3249,7 @@ implementation will be used." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let ((auto-saving - (string-match-p "^#.+#$" (file-name-nondirectory filename))) - file-locked + (let (file-locked (uid (or (tramp-compat-file-attribute-user-id (file-attributes filename 'integer)) (tramp-get-remote-uid v 'integer))) @@ -3260,7 +3258,8 @@ implementation will be used." (tramp-get-remote-gid v 'integer)))) ;; Lock file. - (when (and (not auto-saving) (file-remote-p lockname) + (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) + (file-remote-p lockname) (not (eq (file-locked-p lockname) t))) (setq file-locked t) ;; `lock-file' exists since Emacs 28.1. @@ -3269,15 +3268,11 @@ implementation will be used." (if (and (tramp-local-host-p v) ;; `file-writable-p' calls `file-expand-file-name'. We ;; cannot use `tramp-run-real-handler' therefore. - (let (file-name-handler-alist) - (and - (file-writable-p (file-name-directory localname)) - (or (file-directory-p localname) - (file-writable-p localname))))) + (file-writable-p (file-name-directory localname)) + (or (file-directory-p localname) + (file-writable-p localname))) ;; Short track: if we are on the local host, we can run directly. - (write-region - start end localname append 'no-message - (and lockname (file-local-name lockname))) + (write-region start end localname append 'no-message lockname) (let* ((modes (tramp-default-file-modes filename (and (eq mustbenew 'excl) 'nofollow))) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 87f62391e34..d3de0455dd0 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -1589,14 +1589,13 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let ((auto-saving - (string-match-p "^#.+#$" (file-name-nondirectory filename))) - file-locked + (let (file-locked (curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) ;; Lock file. - (when (and (not auto-saving) (file-remote-p lockname) + (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) + (file-remote-p lockname) (not (eq (file-locked-p lockname) t))) (setq file-locked t) ;; `lock-file' exists since Emacs 28.1. diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 3a3703b267d..f4872cef10c 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -295,12 +295,11 @@ arguments to pass to the OPERATION." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let ((auto-saving - (string-match-p "^#.+#$" (file-name-nondirectory filename))) - file-locked) + (let (file-locked) ;; Lock file. - (when (and (not auto-saving) (file-remote-p lockname) + (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) + (file-remote-p lockname) (not (eq (file-locked-p lockname) t))) (setq file-locked t) ;; `lock-file' exists since Emacs 28.1. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index fc714c9339a..9e6bfceb49a 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -4438,9 +4438,7 @@ of." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let ((auto-saving - (string-match-p "^#.+#$" (file-name-nondirectory filename))) - file-locked + (let (file-locked (tmpfile (tramp-compat-make-temp-file filename)) (modes (tramp-default-file-modes filename (and (eq mustbenew 'excl) 'nofollow))) @@ -4452,7 +4450,8 @@ of." (tramp-get-remote-gid v 'integer)))) ;; Lock file. - (when (and (not auto-saving) (file-remote-p lockname) + (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) + (file-remote-p lockname) (not (eq (file-locked-p lockname) t))) (setq file-locked t) ;; `lock-file' exists since Emacs 28.1. -- cgit v1.2.3 From bfd159539f112785ed215cfd2abb2e2e1f2ea1f6 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Mon, 12 Jul 2021 15:49:50 +0200 Subject: Fix a problem with tramp-*-process-file * lisp/net/tramp-adb.el (tramp-adb-handle-process-file): * lisp/net/tramp-sh.el (tramp-sh-handle-process-file): * lisp/net/tramp-smb.el (tramp-smb-handle-process-file): * lisp/net/tramp-sshfs.el (tramp-sshfs-handle-process-file): Use `(expand-file-name default-directory)'. --- lisp/net/tramp-adb.el | 2 +- lisp/net/tramp-sh.el | 2 +- lisp/net/tramp-smb.el | 2 +- lisp/net/tramp-sshfs.el | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 63fd5eb06a3..dbbbfe6a3f9 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -803,7 +803,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when (and (numberp destination) (zerop destination)) (error "Implementation does not handle immediate return")) - (with-parsed-tramp-file-name default-directory nil + (with-parsed-tramp-file-name (expand-file-name default-directory) nil (let (command input tmpinput stderr tmpstderr outbuf ret) ;; Compute command. (setq command (mapconcat #'tramp-shell-quote-argument diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index e5929bd366a..3595bd26557 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -3029,7 +3029,7 @@ implementation will be used." (when (and (numberp destination) (zerop destination)) (error "Implementation does not handle immediate return")) - (with-parsed-tramp-file-name default-directory nil + (with-parsed-tramp-file-name (expand-file-name default-directory) nil (let (command env uenv input tmpinput stderr tmpstderr outbuf ret) ;; Compute command. (setq command (mapconcat #'tramp-shell-quote-argument diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index d3de0455dd0..1c7ddee0086 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -1259,7 +1259,7 @@ component is used as the target of the symlink." (when (and (numberp destination) (zerop destination)) (error "Implementation does not handle immediate return")) - (with-parsed-tramp-file-name default-directory nil + (with-parsed-tramp-file-name (expand-file-name default-directory) nil (let* ((name (file-name-nondirectory program)) (name1 name) (i 0) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index f4872cef10c..5f6807a0db7 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -235,7 +235,7 @@ arguments to pass to the OPERATION." (when (and (numberp destination) (zerop destination)) (error "Implementation does not handle immediate return")) - (with-parsed-tramp-file-name default-directory nil + (with-parsed-tramp-file-name (expand-file-name default-directory) nil (let ((command (format "cd %s && exec %s" -- cgit v1.2.3 From cce84822f72e6cd4af7bfa351a4da2c9bdc5bb81 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Tue, 13 Jul 2021 19:50:05 +0200 Subject: Add remote-file-name-inhibit-locks * doc/emacs/files.texi (Interlocking): * doc/lispref/files.texi (File Locks): * doc/misc/tramp.texi (Auto-save File Lock and Backup): Add remote-file-name-inhibit-locks. * etc/NEWS: New user option 'remote-file-name-inhibit-locks'. * lisp/files.el (remote-file-name-inhibit-locks): New defcustom. * lisp/net/tramp-adb.el (tramp-adb-file-name-handler-alist): * lisp/net/tramp-crypt.el (tramp-crypt-file-name-handler-alist): * lisp/net/tramp-gvfs.el (tramp-gvfs-file-name-handler-alist): * lisp/net/tramp-rclone.el (tramp-rclone-file-name-handler-alist): * lisp/net/tramp-sh.el (tramp-sh-file-name-handler-alist): * lisp/net/tramp-smb.el (tramp-smb-file-name-handler-alist): * lisp/net/tramp-sshfs.el (tramp-sshfs-file-name-handler-alist): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-file-name-handler-alist): Use `tramp-handle-make-lock-file-name'. * lisp/net/tramp.el (tramp-allow-unsafe-temporary-files): Fix docstring. (tramp-handle-make-lock-file-name): New defun. * test/lisp/net/tramp-tests.el (tramp-test39-lock-file): Extend test. --- doc/emacs/files.texi | 4 +++ doc/lispref/files.texi | 5 ++++ doc/misc/tramp.texi | 10 ++++--- etc/NEWS | 15 ++++++++--- lisp/files.el | 6 +++++ lisp/net/tramp-adb.el | 2 +- lisp/net/tramp-crypt.el | 2 +- lisp/net/tramp-gvfs.el | 2 +- lisp/net/tramp-rclone.el | 2 +- lisp/net/tramp-sh.el | 2 +- lisp/net/tramp-smb.el | 2 +- lisp/net/tramp-sshfs.el | 2 +- lisp/net/tramp-sudoedit.el | 2 +- lisp/net/tramp.el | 26 +++++++++++++++++- test/lisp/net/tramp-tests.el | 64 ++++++++++++++++++++++++++++++-------------- 15 files changed, 110 insertions(+), 36 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi index 98b6b194d2d..32a2f1bb815 100644 --- a/doc/emacs/files.texi +++ b/doc/emacs/files.texi @@ -836,6 +836,10 @@ warning message and asks for confirmation before saving; answer place, one way to compare the buffer to its file is the @kbd{M-x diff-buffer-with-file} command. @xref{Comparing Files}. +@vindex remote-file-name-inhibit-locks + You can prevent the creation of remote lock files by setting the +variable @code{remote-file-name-inhibit-locks} to @code{t}. + @node File Shadowing @subsection Shadowing Files @cindex shadow files diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index b1b70a9f063..1f4049f715c 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -821,6 +821,11 @@ If you wish, you can replace the @code{ask-user-about-lock} function with your own version that makes the decision in another way. @end defun +@defopt remote-file-name-inhibit-locks +You can prevent the creation of remote lock files by setting the +variable @code{remote-file-name-inhibit-locks} to @code{t}. +@end defopt + @node Information about Files @section Information about Files @cindex file, information about diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 8ba5f0118a3..088352e8a8a 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -2858,11 +2858,15 @@ to warn you, if a file is changed in parallel from different Emacs sessions, or via different remote connections. Be careful with such settings. +@vindex remote-file-name-inhibit-locks +Setting @code{remote-file-name-inhibit-locks} to non-@code{nil} +prevents the creation of remote lock files at all. + @vindex tramp-allow-unsafe-temporary-files Per default, @value{tramp} asks for confirmation if a -@samp{root}-owned backup or auto-save remote file has to be written to -your local temporary directory. If you want to suppress this -confirmation question, set user option +@samp{root}-owned remote backup, auto-save or lock file has to be +written to your local temporary directory. If you want to suppress +this confirmation question, set user option @code{tramp-allow-unsafe-temporary-files} to @code{t}. diff --git a/etc/NEWS b/etc/NEWS index 923cfcc4722..fd661a1e7a6 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1464,12 +1464,15 @@ buffer to a file under the "/tmp/" directory. This is useful, if (in rare cases) Tramp blocks Emacs, and we need further debug information. +++ -*** Writing sensitive auto-save or backup files to the local temporary -directory must be confirmed. In order to suppress this confirmation, -set user option 'tramp-allow-unsafe-temporary-files' to t. +*** Tramp supports lock files now. +In order to deactivate this, set user option +'remote-file-name-inhibit-locks' to t. +++ -*** Tramp supports file locks now. +*** Writing sensitive auto-save, backup or lock files to the local +temporary directory must be confirmed. In order to suppress this +confirmation, set user option 'tramp-allow-unsafe-temporary-files' to +t. ** Tempo @@ -2182,6 +2185,10 @@ summaries will include the failing condition. This option allows controlling where lock files are written. It uses the same syntax as 'auto-save-file-name-transforms'. ++++ +*** New user option 'remote-file-name-inhibit-locks'. +When non-nil, this option suppresses lock files for remote files. + +++ *** New user option 'kill-transform-function'. This can be used to transform (and suppress) strings from entering the diff --git a/lisp/files.el b/lisp/files.el index 0dfcab8f89b..ad02d373fd0 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -427,6 +427,12 @@ file it's locking, and it has the same name, but with \".#\" prepended." :initialize 'custom-initialize-delay :version "28.1") +(defcustom remote-file-name-inhibit-locks nil + "Whether to use file locks for remote files." + :group 'files + :version "28.1" + :type 'boolean) + (defvar auto-save--timer nil "Timer for `auto-save-visited-mode'.") (defcustom auto-save-visited-interval 5 diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index dbbbfe6a3f9..8138d9a3608 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -164,7 +164,7 @@ It is used for TCP/IP devices." (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-adb-handle-make-directory) (make-directory-internal . ignore) - ;; `make-lock-file-name' performed by default handler. + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-adb-handle-make-process) (make-symbolic-link . tramp-handle-make-symbolic-link) diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 1b77fea7e18..109db3b1d7b 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -213,7 +213,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-crypt-handle-make-directory) (make-directory-internal . ignore) - ;; `make-lock-file-name' performed by default handler. + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 04de5defb37..022fdeeb885 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -805,7 +805,7 @@ It has been changed in GVFS 1.14.") (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-gvfs-handle-make-directory) (make-directory-internal . ignore) - ;; `make-lock-file-name' performed by default handler. + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 473fa8a8f0e..49e366c01c6 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -127,7 +127,7 @@ (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-fuse-handle-make-directory) (make-directory-internal . ignore) - ;; `make-lock-file-name' performed by default handler. + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 3595bd26557..760320d7ed4 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -993,7 +993,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (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-lock-file-name' performed by default handler. + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-sh-handle-make-process) (make-symbolic-link . tramp-sh-handle-make-symbolic-link) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 1c7ddee0086..4008c25d3af 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -278,7 +278,7 @@ See `tramp-actions-before-shell' for more info.") (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-smb-handle-make-directory) (make-directory-internal . tramp-smb-handle-make-directory-internal) - ;; `make-lock-file-name' performed by default handler. + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-smb-handle-make-symbolic-link) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 5f6807a0db7..99f4063988f 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -127,7 +127,7 @@ (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-fuse-handle-make-directory) (make-directory-internal . ignore) - ;; `make-lock-file-name' performed by default handler. + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-handle-make-process) (make-symbolic-link . tramp-handle-make-symbolic-link) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index d68a5c1adf4..45d9fab986c 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -120,7 +120,7 @@ See `tramp-actions-before-shell' for more info.") (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-sudoedit-handle-make-directory) (make-directory-internal . ignore) - ;; `make-lock-file-name' performed by default handler. + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-sudoedit-handle-make-symbolic-link) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 9e6bfceb49a..3f586c62170 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3630,7 +3630,7 @@ User is always nil." (file-writable-p (file-name-directory filename))))))) (defcustom tramp-allow-unsafe-temporary-files nil - "Whether root-owned auto-save or backup files can be written to \"/tmp\"." + "Whether root-owned auto-save, backup or lock files can be written to \"/tmp\"." :version "28.1" :type 'boolean) @@ -3880,6 +3880,30 @@ Return nil when there is no lockfile." (write-region info nil lockname) (set-file-modes lockname #o0644)))))))) +(defun tramp-handle-make-lock-file-name (file) + "Like `make-lock-file-name' for Tramp files." + (when (and create-lockfiles + ;; This variable has been introduced with Emacs 28.1. + (not (bound-and-true-p remote-file-name-inhibit-locks))) + (with-parsed-tramp-file-name file nil + (let ((result + ;; Run plain `make-lock-file-name'. + (tramp-run-real-handler #'make-lock-file-name (list file)))) + ;; Protect against security hole. + (when (and (not tramp-allow-unsafe-temporary-files) + (file-in-directory-p result temporary-file-directory) + (zerop (or (tramp-compat-file-attribute-user-id + (file-attributes file 'integer)) + tramp-unknown-id-integer)) + (not (with-tramp-connection-property + (tramp-get-process v) "unsafe-temporary-file" + (yes-or-no-p + (concat + "Lock file on local temporary directory, " + "do you want to continue? "))))) + (tramp-error v 'file-error "Unsafe lock file name")) + result)))) + (defun tramp-handle-unlock-file (file) "Like `unlock-file' for Tramp files." (when-let ((lockname (tramp-compat-make-lock-file-name file))) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 44fd1b45b26..bc05db8095b 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -5751,8 +5751,10 @@ Use direct async.") (skip-unless (and (fboundp 'lock-file) (fboundp 'unlock-file))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) - (let ((tmp-name (tramp--test-make-temp-name nil quoted)) + (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) + (tmp-name2 (tramp--test-make-temp-name nil quoted)) (remote-file-name-inhibit-cache t) + (remote-file-name-inhibit-locks nil) (create-lockfiles t) (inhibit-message t) ;; tramp-rclone.el and tramp-sshfs.el cache the mounted files. @@ -5765,51 +5767,73 @@ Use direct async.") (unwind-protect (progn ;; A simple file lock. - (should-not (file-locked-p tmp-name)) - (lock-file tmp-name) - (should (eq (file-locked-p tmp-name) t)) + (should-not (file-locked-p tmp-name1)) + (lock-file tmp-name1) + (should (eq (file-locked-p tmp-name1) t)) ;; If it is locked already, nothing changes. - (lock-file tmp-name) - (should (eq (file-locked-p tmp-name) t)) + (lock-file tmp-name1) + (should (eq (file-locked-p tmp-name1) t)) ;; A new connection changes process id, and also the ;; lockname contents. (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) - (should (stringp (file-locked-p tmp-name))) + (should (stringp (file-locked-p tmp-name1))) + + ;; When `remote-file-name-inhibit-locks' is set, nothing happens. + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) + (let ((remote-file-name-inhibit-locks t)) + (lock-file tmp-name1) + (should-not (file-locked-p tmp-name1))) + + ;; When `lock-file-name-transforms' is set, another lock + ;; file is used. + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) + (let ((lock-file-name-transforms `((".*" ,tmp-name2)))) + (should + (string-equal + (make-lock-file-name tmp-name1) + (make-lock-file-name tmp-name2))) + (lock-file tmp-name1) + (should (eq (file-locked-p tmp-name1) t)) + (unlock-file tmp-name1) + (should-not (file-locked-p tmp-name1))) ;; Steal the file lock. (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (cl-letf (((symbol-function #'read-char) (lambda (&rest _args) ?s))) - (lock-file tmp-name)) - (should (eq (file-locked-p tmp-name) t)) + (lock-file tmp-name1)) + (should (eq (file-locked-p tmp-name1) t)) ;; Ignore the file lock. (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (cl-letf (((symbol-function #'read-char) (lambda (&rest _args) ?p))) - (lock-file tmp-name)) - (should (stringp (file-locked-p tmp-name))) + (lock-file tmp-name1)) + (should (stringp (file-locked-p tmp-name1))) ;; Quit the file lock machinery. (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (cl-letf (((symbol-function #'read-char) (lambda (&rest _args) ?q))) - (should-error (lock-file tmp-name) :type 'file-locked) + (should-error (lock-file tmp-name1) :type 'file-locked) ;; The same for `write-region'. - (should-error (write-region "foo" nil tmp-name) :type 'file-locked) (should-error - (write-region "foo" nil tmp-name nil nil tmp-name) + (write-region "foo" nil tmp-name1) :type 'file-locked) + (should-error + (write-region "foo" nil tmp-name1 nil nil tmp-name1) :type 'file-locked) ;; The same for `set-visited-file-name'. (with-temp-buffer (should-error - (set-visited-file-name tmp-name) :type 'file-locked))) - (should (stringp (file-locked-p tmp-name))) - (should-not (file-exists-p tmp-name))) + (set-visited-file-name tmp-name1) :type 'file-locked))) + (should (stringp (file-locked-p tmp-name1))) + (should-not (file-exists-p tmp-name1))) ;; Cleanup. - (ignore-errors (delete-file tmp-name)) - (unlock-file tmp-name) - (should-not (file-locked-p tmp-name)))))) + (ignore-errors (delete-file tmp-name1)) + (unlock-file tmp-name1) + (unlock-file tmp-name2) + (should-not (file-locked-p tmp-name1)) + (should-not (file-locked-p tmp-name2)))))) ;; The functions were introduced in Emacs 26.1. (ert-deftest tramp-test40-make-nearby-temp-file () -- cgit v1.2.3 From 525d5cab36fe7e719ecc49b88a1ac68abbe7924c Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Wed, 14 Jul 2021 18:36:14 +0200 Subject: Preserve backward compatibility in Tramp * lisp/net/tramp-crypt.el (tramp-crypt-handle-lock-file) (tramp-crypt-handle-unlock-file): Preserve backward compatibility. * lisp/net/tramp-sh.el (tramp-sh-handle-write-region): Do not create lock file twice. * lisp/net/tramp.el (tramp-handle-make-lock-file-name): Move lock file security check ... (tramp-handle-lock-file): ... here. (tramp-handle-unlock-file): Preserve backward compatibility. * test/lisp/net/tramp-tests.el (lock-file-name-transforms) (remote-file-name-inhibit-locks): Declare. (tramp-allow-unsafe-temporary-files): Set to t. (tramp-test37-make-auto-save-file-name) (tramp-test38-find-backup-file-name): Move binding of `tramp-allow-unsafe-temporary-files' up. (tramp-test39-lock-file): Bind `tramp-allow-unsafe-temporary-files'. Preserve backward compatibility. Extend test. --- lisp/net/tramp-crypt.el | 8 +++- lisp/net/tramp-sh.el | 3 +- lisp/net/tramp.el | 49 +++++++++++----------- test/lisp/net/tramp-tests.el | 97 ++++++++++++++++++++++++++++++-------------- 4 files changed, 100 insertions(+), 57 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 109db3b1d7b..fdb2907ec32 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -809,7 +809,9 @@ WILDCARD is not supported." (defun tramp-crypt-handle-lock-file (filename) "Like `lock-file' for Tramp files." (let (tramp-crypt-enabled) - (lock-file (tramp-crypt-encrypt-file-name filename)))) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall + 'lock-file (tramp-crypt-encrypt-file-name filename)))) (defun tramp-crypt-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -865,7 +867,9 @@ WILDCARD is not supported." (defun tramp-crypt-handle-unlock-file (filename) "Like `unlock-file' for Tramp files." (let (tramp-crypt-enabled) - (unlock-file (tramp-crypt-encrypt-file-name filename)))) + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall + 'unlock-file (tramp-crypt-encrypt-file-name filename)))) (add-hook 'tramp-unload-hook (lambda () diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 760320d7ed4..e6bd42a83ae 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -3272,7 +3272,8 @@ implementation will be used." (or (file-directory-p localname) (file-writable-p localname))) ;; Short track: if we are on the local host, we can run directly. - (write-region start end localname append 'no-message lockname) + (let ((create-lockfiles (not file-locked))) + (write-region start end localname append 'no-message lockname)) (let* ((modes (tramp-default-file-modes filename (and (eq mustbenew 'excl) 'nofollow))) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 3f586c62170..736c7efd242 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3873,43 +3873,44 @@ Return nil when there is no lockfile." (format "%s@%s.%s" (user-login-name) (system-name) (tramp-get-lock-pid file)))) + + ;; Protect against security hole. + (with-parsed-tramp-file-name file nil + (when (and (not tramp-allow-unsafe-temporary-files) + (file-in-directory-p lockname temporary-file-directory) + (zerop (or (tramp-compat-file-attribute-user-id + (file-attributes file 'integer)) + tramp-unknown-id-integer)) + (not (with-tramp-connection-property + (tramp-get-process v) "unsafe-temporary-file" + (yes-or-no-p + (concat + "Lock file on local temporary directory, " + "do you want to continue? "))))) + (tramp-error v 'file-error "Unsafe lock file name"))) + + ;; Do the lock. (let (create-lockfiles signal-hook-function) (condition-case nil (make-symbolic-link info lockname 'ok-if-already-exists) (error - (write-region info nil lockname) - (set-file-modes lockname #o0644)))))))) + (with-file-modes #o0644 + (write-region info nil lockname))))))))) (defun tramp-handle-make-lock-file-name (file) "Like `make-lock-file-name' for Tramp files." - (when (and create-lockfiles - ;; This variable has been introduced with Emacs 28.1. - (not (bound-and-true-p remote-file-name-inhibit-locks))) - (with-parsed-tramp-file-name file nil - (let ((result - ;; Run plain `make-lock-file-name'. - (tramp-run-real-handler #'make-lock-file-name (list file)))) - ;; Protect against security hole. - (when (and (not tramp-allow-unsafe-temporary-files) - (file-in-directory-p result temporary-file-directory) - (zerop (or (tramp-compat-file-attribute-user-id - (file-attributes file 'integer)) - tramp-unknown-id-integer)) - (not (with-tramp-connection-property - (tramp-get-process v) "unsafe-temporary-file" - (yes-or-no-p - (concat - "Lock file on local temporary directory, " - "do you want to continue? "))))) - (tramp-error v 'file-error "Unsafe lock file name")) - result)))) + (and create-lockfiles + ;; This variable has been introduced with Emacs 28.1. + (not (bound-and-true-p remote-file-name-inhibit-locks)) + (tramp-run-real-handler 'make-lock-file-name (list file)))) (defun tramp-handle-unlock-file (file) "Like `unlock-file' for Tramp files." (when-let ((lockname (tramp-compat-make-lock-file-name file))) (condition-case err (delete-file lockname) - (error (userlock--handle-unlock-error err))))) + ;; `userlock--handle-unlock-error' exists since Emacs 28.1. + (error (tramp-compat-funcall 'userlock--handle-unlock-error err))))) (defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix) "Like `load' for Tramp files." diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index bc05db8095b..3dd22acea51 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -63,6 +63,8 @@ (declare-function tramp-smb-get-localname "tramp-smb") (defvar ange-ftp-make-backup-files) (defvar auto-save-file-name-transforms) +(defvar lock-file-name-transforms) +(defvar remote-file-name-inhibit-locks) (defvar tramp-connection-properties) (defvar tramp-copy-size-limit) (defvar tramp-display-escape-sequence-regexp) @@ -122,6 +124,7 @@ (setq auth-source-save-behavior nil password-cache-expiry nil remote-file-name-inhibit-cache nil + tramp-allow-unsafe-temporary-files t tramp-cache-read-persistent-data t ;; For auth-sources. tramp-copy-size-limit nil tramp-persistency-file-name nil @@ -5481,7 +5484,8 @@ Use direct async.") (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) - (tmp-name2 (tramp--test-make-temp-name nil quoted))) + (tmp-name2 (tramp--test-make-temp-name nil quoted)) + tramp-allow-unsafe-temporary-files) (unwind-protect (progn @@ -5569,8 +5573,7 @@ Use direct async.") ;; Create temporary file. This shall check for sensible ;; files, owned by root. - (let ((tramp-auto-save-directory temporary-file-directory) - tramp-allow-unsafe-temporary-files) + (let ((tramp-auto-save-directory temporary-file-directory)) (write-region "foo" nil tmp-name1) (when (zerop (or (tramp-compat-file-attribute-user-id (file-attributes tmp-name1)) @@ -5606,6 +5609,7 @@ Use direct async.") (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (ange-ftp-make-backup-files t) + tramp-allow-unsafe-temporary-files ;; These settings are not used by Tramp, so we ignore them. version-control delete-old-versions (kept-old-versions (default-toplevel-value 'kept-old-versions)) @@ -5716,7 +5720,6 @@ Use direct async.") ;; Create temporary file. This shall check for sensible ;; files, owned by root. (let ((backup-directory-alist `(("." . ,temporary-file-directory))) - tramp-allow-unsafe-temporary-files tramp-backup-directory-alist) (write-region "foo" nil tmp-name1) (when (zerop (or (tramp-compat-file-attribute-user-id @@ -5749,13 +5752,18 @@ Use direct async.") (skip-unless (not (tramp--test-ange-ftp-p))) ;; Since Emacs 28.1. (skip-unless (and (fboundp 'lock-file) (fboundp 'unlock-file))) + (skip-unless (and (fboundp 'file-locked-p) (fboundp 'make-lock-file-name))) + ;; `lock-file', `unlock-file', `file-locked-p' and + ;; `make-lock-file-name' exists since Emacs 28.1. We don't want to + ;; see compiler warnings for older Emacsen. (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (remote-file-name-inhibit-cache t) (remote-file-name-inhibit-locks nil) (create-lockfiles t) + tramp-allow-unsafe-temporary-files (inhibit-message t) ;; tramp-rclone.el and tramp-sshfs.el cache the mounted files. (tramp-cleanup-connection-hook @@ -5767,24 +5775,24 @@ Use direct async.") (unwind-protect (progn ;; A simple file lock. - (should-not (file-locked-p tmp-name1)) - (lock-file tmp-name1) - (should (eq (file-locked-p tmp-name1) t)) + (should-not (with-no-warnings (file-locked-p tmp-name1))) + (with-no-warnings (lock-file tmp-name1)) + (should (eq (with-no-warnings (file-locked-p tmp-name1)) t)) ;; If it is locked already, nothing changes. - (lock-file tmp-name1) - (should (eq (file-locked-p tmp-name1) t)) + (with-no-warnings (lock-file tmp-name1)) + (should (eq (with-no-warnings (file-locked-p tmp-name1)) t)) ;; A new connection changes process id, and also the ;; lockname contents. (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) - (should (stringp (file-locked-p tmp-name1))) + (should (stringp (with-no-warnings (file-locked-p tmp-name1)))) ;; When `remote-file-name-inhibit-locks' is set, nothing happens. (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (let ((remote-file-name-inhibit-locks t)) - (lock-file tmp-name1) - (should-not (file-locked-p tmp-name1))) + (with-no-warnings (lock-file tmp-name1)) + (should-not (with-no-warnings (file-locked-p tmp-name1)))) ;; When `lock-file-name-transforms' is set, another lock ;; file is used. @@ -5792,48 +5800,77 @@ Use direct async.") (let ((lock-file-name-transforms `((".*" ,tmp-name2)))) (should (string-equal - (make-lock-file-name tmp-name1) - (make-lock-file-name tmp-name2))) - (lock-file tmp-name1) - (should (eq (file-locked-p tmp-name1) t)) - (unlock-file tmp-name1) - (should-not (file-locked-p tmp-name1))) + (with-no-warnings (make-lock-file-name tmp-name1)) + (with-no-warnings (make-lock-file-name tmp-name2)))) + (with-no-warnings (lock-file tmp-name1)) + (should (eq (with-no-warnings (file-locked-p tmp-name1)) t)) + (with-no-warnings (unlock-file tmp-name1)) + (should-not (with-no-warnings (file-locked-p tmp-name1)))) ;; Steal the file lock. (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (cl-letf (((symbol-function #'read-char) (lambda (&rest _args) ?s))) - (lock-file tmp-name1)) - (should (eq (file-locked-p tmp-name1) t)) + (with-no-warnings (lock-file tmp-name1))) + (should (eq (with-no-warnings (file-locked-p tmp-name1)) t)) ;; Ignore the file lock. (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (cl-letf (((symbol-function #'read-char) (lambda (&rest _args) ?p))) - (lock-file tmp-name1)) - (should (stringp (file-locked-p tmp-name1))) + (with-no-warnings (lock-file tmp-name1))) + (should (stringp (with-no-warnings (file-locked-p tmp-name1)))) ;; Quit the file lock machinery. (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (cl-letf (((symbol-function #'read-char) (lambda (&rest _args) ?q))) - (should-error (lock-file tmp-name1) :type 'file-locked) + (with-no-warnings + (should-error + (lock-file tmp-name1) + :type 'file-locked)) ;; The same for `write-region'. (should-error - (write-region "foo" nil tmp-name1) :type 'file-locked) + (write-region "foo" nil tmp-name1) + :type 'file-locked) (should-error (write-region "foo" nil tmp-name1 nil nil tmp-name1) :type 'file-locked) ;; The same for `set-visited-file-name'. (with-temp-buffer (should-error - (set-visited-file-name tmp-name1) :type 'file-locked))) - (should (stringp (file-locked-p tmp-name1))) + (set-visited-file-name tmp-name1) + :type 'file-locked))) + (should (stringp (with-no-warnings (file-locked-p tmp-name1)))) (should-not (file-exists-p tmp-name1))) ;; Cleanup. (ignore-errors (delete-file tmp-name1)) - (unlock-file tmp-name1) - (unlock-file tmp-name2) - (should-not (file-locked-p tmp-name1)) - (should-not (file-locked-p tmp-name2)))))) + (with-no-warnings (unlock-file tmp-name1)) + (with-no-warnings (unlock-file tmp-name2)) + (should-not (with-no-warnings (file-locked-p tmp-name1))) + (should-not (with-no-warnings (file-locked-p tmp-name2)))) + + (unwind-protect + ;; Create temporary file. This shall check for sensible + ;; files, owned by root. + (let ((lock-file-name-transforms auto-save-file-name-transforms)) + (write-region "foo" nil tmp-name1) + (when (zerop (or (tramp-compat-file-attribute-user-id + (file-attributes tmp-name1)) + tramp-unknown-id-integer)) + (tramp-cleanup-connection + tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) + (should-error + (write-region "foo" nil tmp-name1) + :type 'file-error)) + (tramp-cleanup-connection + tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'yes-or-no-p) + #'tramp--test-always)) + (write-region "foo" nil tmp-name1)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password))))) ;; The functions were introduced in Emacs 26.1. (ert-deftest tramp-test40-make-nearby-temp-file () -- cgit v1.2.3 From 1bd012ce439382e1da49e711ac74ac0a07d05075 Mon Sep 17 00:00:00 2001 From: Naofumi Yasufuku Date: Sun, 18 Jul 2021 16:57:53 +0200 Subject: Make remote file locks more robust. (Bug#49621) * lisp/net/tramp-sh.el (tramp-sh-handle-write-region): Make file locks more robust. (Bug#49621) Copyright-paperwork-exempt: yes --- lisp/net/tramp-sh.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index e6bd42a83ae..8b4c78fe65b 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -3249,7 +3249,7 @@ implementation will be used." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let (file-locked + (let ((file-locked (eq (file-locked-p lockname) t)) (uid (or (tramp-compat-file-attribute-user-id (file-attributes filename 'integer)) (tramp-get-remote-uid v 'integer))) @@ -3260,7 +3260,7 @@ implementation will be used." ;; Lock file. (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) (file-remote-p lockname) - (not (eq (file-locked-p lockname) t))) + (not file-locked)) (setq file-locked t) ;; `lock-file' exists since Emacs 28.1. (tramp-compat-funcall 'lock-file lockname)) @@ -3481,7 +3481,7 @@ implementation will be used." (tramp-set-file-uid-gid filename uid gid)) ;; Unlock file. - (when (and file-locked (eq (file-locked-p lockname) t)) + (when file-locked ;; `unlock-file' exists since Emacs 28.1. (tramp-compat-funcall 'unlock-file lockname)) -- cgit v1.2.3 From eb20d013a1717a0ecc6ee3563e69261aaf7c98eb Mon Sep 17 00:00:00 2001 From: Alex Bochannek Date: Fri, 23 Jul 2021 20:29:59 +0200 Subject: Fix bug#49699 * lisp/net/tramp-sh.el (tramp-scp-strict-file-name-checking): Adapt check for macOS. (Bug#49699) --- lisp/net/tramp-sh.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 8b4c78fe65b..f94508303df 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -4782,7 +4782,9 @@ Goes through the list `tramp-inline-compress-commands'." (with-temp-buffer (tramp-call-process vec "scp" nil t nil "-T") (goto-char (point-min)) - (unless (search-forward-regexp "unknown option -- T" nil t) + (unless + (search-forward-regexp + "\\(illegal\\|unknown\\) option -- T" nil t) (setq tramp-scp-strict-file-name-checking "-T"))))))) tramp-scp-strict-file-name-checking))) -- cgit v1.2.3 From 9ad1f71c39eda81237df048cc170bee6e4216d97 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 24 Jul 2021 13:58:03 +0200 Subject: Add Tramp support for yubikey (bug#49714) * lisp/net/tramp.el (tramp-yubikey-regexp): New defcustom. (tramp-action-show-and-confirm-message): New defun. * lisp/net/tramp-sh.el (tramp-actions-before-shell) (tramp-actions-copy-out-of-band): Add `tramp-yubikey-regexp' action. --- lisp/net/tramp-sh.el | 2 ++ lisp/net/tramp.el | 23 +++++++++++++++++++++++ 2 files changed, 25 insertions(+) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index f94508303df..41ab1045c24 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -519,6 +519,7 @@ shell from reading its init file." (tramp-yn-prompt-regexp tramp-action-yn) (tramp-terminal-prompt-regexp tramp-action-terminal) (tramp-antispoof-regexp tramp-action-confirm-message) + (tramp-yubikey-regexp tramp-action-show-and-confirm-message) (tramp-process-alive-regexp tramp-action-process-alive)) "List of pattern/action pairs. Whenever a pattern matches, the corresponding action is performed. @@ -536,6 +537,7 @@ corresponding PATTERN matches, the ACTION function is called.") '((tramp-password-prompt-regexp tramp-action-password) (tramp-wrong-passwd-regexp tramp-action-permission-denied) (tramp-copy-failed-regexp tramp-action-permission-denied) + (tramp-yubikey-regexp tramp-action-show-and-confirm-message) (tramp-process-alive-regexp tramp-action-out-of-band)) "List of pattern/action pairs. This list is used for copying/renaming with out-of-band methods. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 093335a77b5..24953f751e9 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -698,6 +698,15 @@ The regexp should match at end of buffer." :version "27.1" :type 'regexp) +;; Yubikey requires the user physically to touch the device with their +;; finger. We must tell it to the user. +(defcustom tramp-yubikey-regexp + (regexp-quote "Confirm user presence for key .*") + "Regular expression matching yubikey confirmation message. +The regexp should match at end of buffer." + :version "28.1" + :type 'regexp) + (defcustom tramp-operation-not-permitted-regexp (concat "\\(" "preserving times.*" "\\|" "set mode" "\\)" ":\\s-*" (regexp-opt '("Operation not permitted") t)) @@ -4669,6 +4678,20 @@ The terminal type can be configured with `tramp-terminal-type'." (tramp-send-string vec tramp-local-end-of-line) t) +(defun tramp-action-show-and-confirm-message (_proc vec) + "Show the user a message for confirmation. +Wait, until the user has entered RET." + (save-window-excursion + (let ((enable-recursive-minibuffers t) + (stimers (with-timeout-suspend))) + (with-current-buffer (tramp-get-connection-buffer vec) + (tramp-message vec 6 "\n%s" (buffer-string)) + (pop-to-buffer (current-buffer))) + (read-string "Press ENTER to continue") + ;; Reenable the timers. + (with-timeout-unsuspend stimers))) + t) + (defun tramp-action-process-alive (proc _vec) "Check, whether a process has finished." (unless (process-live-p proc) -- cgit v1.2.3 From 0577bd0cf9aca220c0ecba217ac9a9522ffa990d Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sun, 25 Jul 2021 12:05:01 +0200 Subject: Use `file-name-concat' in Tramp * lisp/net/tramp-compat.el (tramp-compat-file-name-concat): New defalias. * lisp/net/tramp.el (tramp-handle-expand-file-name): * lisp/net/tramp-adb.el (tramp-adb-handle-directory-files-and-attributes): * lisp/net/tramp-gvfs.el (tramp-gvfs-handle-expand-file-name): * lisp/net/tramp-sh.el (tramp-sh-handle-expand-file-name): * lisp/net/tramp-smb.el (tramp-smb-handle-expand-file-name): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-handle-expand-file-name): Use it. --- lisp/net/tramp-adb.el | 4 ++-- lisp/net/tramp-compat.el | 14 ++++++++++++++ lisp/net/tramp-gvfs.el | 2 +- lisp/net/tramp-sh.el | 2 +- lisp/net/tramp-smb.el | 2 +- lisp/net/tramp-sudoedit.el | 2 +- lisp/net/tramp.el | 2 +- 7 files changed, 21 insertions(+), 7 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index b081e5957a3..5e0accc142a 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -327,9 +327,9 @@ arguments to pass to the OPERATION." v (format "%s -d -a -l %s %s" (tramp-adb-get-ls-command v) (tramp-shell-quote-argument - (concat (file-name-as-directory localname) ".")) + (tramp-compat-file-name-concat localname ".")) (tramp-shell-quote-argument - (concat (file-name-as-directory localname) "..")))) + (tramp-compat-file-name-concat localname "..")))) (widen))) (tramp-adb-sh-fix-ls-output) (let ((result (tramp-do-parse-file-attributes-with-ls diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 9d5e5f787b6..6e464073379 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -363,6 +363,20 @@ A nil value for either argument stands for the current time." ".#" (file-name-nondirectory filename)) (file-name-directory filename))))) +;; Function `file-name-concat' is new in Emacs 28.1. +(defalias 'tramp-compat-file-name-concat + (if (fboundp 'file-name-concat) + #'file-name-concat + (lambda (directory &rest components) + (unless (null directory) + (let ((components (delq nil components)) + file-name-handler-alist) + (if (null components) + directory + (tramp-compat-file-name-concat + (concat (file-name-as-directory directory) (car components)) + (cdr components)))))))) + (dolist (elt (all-completions "tramp-compat-" obarray 'functionp)) (put (intern elt) 'tramp-suppress-trace t)) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 022fdeeb885..db561b4fd0c 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -1142,7 +1142,7 @@ file names." (when (zerop (length name)) (setq name ".")) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) - (setq name (concat (file-name-as-directory dir) name))) + (setq name (tramp-compat-file-name-concat dir name))) ;; If NAME is not a Tramp file, run the real handler. (if (not (tramp-tramp-file-p name)) (tramp-run-real-handler #'expand-file-name (list name nil)) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 41ab1045c24..a6569e0cdd2 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2681,7 +2681,7 @@ the result will be a local, non-Tramp, file name." (tramp-run-real-handler #'expand-file-name (list name dir)) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) - (setq name (concat (file-name-as-directory dir) name))) + (setq name (tramp-compat-file-name-concat dir name))) ;; If connection is not established yet, run the real handler. (if (not (tramp-connectable-p name)) (tramp-run-real-handler #'expand-file-name (list name nil)) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 4e4f5548e20..3d5be61d3f0 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -722,7 +722,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when (zerop (length name)) (setq name ".")) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) - (setq name (concat (file-name-as-directory dir) name))) + (setq name (tramp-compat-file-name-concat dir name))) ;; If NAME is not a Tramp file, run the real handler. (if (not (tramp-tramp-file-p name)) (tramp-run-real-handler #'expand-file-name (list name nil)) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 45d9fab986c..177dde67cca 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -353,7 +353,7 @@ the result will be a local, non-Tramp, file name." (when (zerop (length name)) (setq name ".")) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) - (setq name (concat (file-name-as-directory dir) name))) + (setq name (tramp-compat-file-name-concat dir name))) (with-parsed-tramp-file-name name nil ;; Tilde expansion if necessary. We cannot accept "~/", because ;; under sudo "~/" is expanded to the local user home directory diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 59c4f33f5ef..4db0b2e6723 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3346,7 +3346,7 @@ User is always nil." (when (zerop (length name)) (setq name ".")) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) - (setq name (concat (file-name-as-directory dir) name))) + (setq name (tramp-compat-file-name-concat dir name))) ;; If NAME is not a Tramp file, run the real handler. (if (not (tramp-tramp-file-p name)) (tramp-run-real-handler #'expand-file-name (list name nil)) -- cgit v1.2.3 From 41e62df73af373f30a89281b25be0344b14cf98b Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sun, 25 Jul 2021 14:14:49 +0200 Subject: Fix extended attributes for Tramp's sudoedit method (bug#49724) * lisp/net/tramp-sh.el (tramp-do-copy-or-rename-file): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-do-copy-or-rename-file): Remove compat code for `{set-}file-extended-attributes'. (tramp-sudoedit-handle-write-region): Handle extended attributes. (Bug#49724) * test/lisp/net/tramp-tests.el (tramp-test25-file-selinux): Fix test for sudoedit method. --- lisp/net/tramp-sh.el | 4 ++-- lisp/net/tramp-sudoedit.el | 18 ++++++++++++------ test/lisp/net/tramp-tests.el | 2 +- 3 files changed, 15 insertions(+), 9 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index a6569e0cdd2..7cf90b96612 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1946,7 +1946,7 @@ file names." (length (tramp-compat-file-attribute-size (file-attributes (file-truename filename)))) (attributes (and preserve-extended-attributes - (apply #'file-extended-attributes (list filename)))) + (file-extended-attributes filename))) (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) (with-parsed-tramp-file-name (if t1 filename newname) nil @@ -2022,7 +2022,7 @@ file names." ;; errors, because ACL strings could be incompatible. (when attributes (ignore-errors - (apply #'set-file-extended-attributes (list newname attributes)))) + (set-file-extended-attributes newname attributes))) ;; In case of `rename', we must flush the cache of the source file. (when (and t1 (eq op 'rename)) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 177dde67cca..e4d90dde701 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -237,7 +237,7 @@ absolute file names." (file-attributes filename))) (file-modes (tramp-default-file-modes filename)) (attributes (and preserve-extended-attributes - (apply #'file-extended-attributes (list filename)))) + (file-extended-attributes filename))) (sudoedit-operation (cond ((and (eq op 'copy) preserve-uid-gid) '("cp" "-f" "-p")) @@ -293,7 +293,7 @@ absolute file names." ;; errors, because ACL strings could be incompatible. (when attributes (ignore-errors - (apply #'set-file-extended-attributes (list newname attributes)))) + (set-file-extended-attributes newname attributes))) (when (and t1 (eq op 'rename)) (with-parsed-tramp-file-name filename v1 @@ -726,13 +726,14 @@ ID-FORMAT valid values are `string' and `integer'." (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer))) (flag (and (eq mustbenew 'excl) 'nofollow)) - (modes (tramp-default-file-modes filename flag))) + (modes (tramp-default-file-modes filename flag)) + (attributes (file-extended-attributes filename))) (prog1 (tramp-handle-write-region start end filename append visit lockname mustbenew) - ;; Set the ownership and modes. This is not performed in - ;; `tramp-handle-write-region'. + ;; Set the ownership, modes and extended attributes. This is + ;; not performed in `tramp-handle-write-region'. (unless (and (= (tramp-compat-file-attribute-user-id (file-attributes filename 'integer)) uid) @@ -740,7 +741,12 @@ ID-FORMAT valid values are `string' and `integer'." (file-attributes filename 'integer)) gid)) (tramp-set-file-uid-gid filename uid gid)) - (tramp-compat-set-file-modes filename modes flag))))) + (tramp-compat-set-file-modes filename modes flag) + ;; We ignore possible errors, because ACL strings could be + ;; incompatible. + (when attributes + (ignore-errors + (set-file-extended-attributes filename attributes))))))) ;; Internal functions. diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index b3a00215ac3..052c03029fd 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -4096,7 +4096,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (write-region "foo" nil tmp-name1) (should (file-exists-p tmp-name1)) (should (file-selinux-context tmp-name1)) - (copy-file tmp-name1 tmp-name2) + (copy-file tmp-name1 tmp-name2 nil nil nil 'preserve-permissions) (should (file-selinux-context tmp-name2)) (should (equal -- cgit v1.2.3 From 80cccd7ff15d254cb412e9939e27a348fbaa0425 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Tue, 3 Aug 2021 22:08:18 +0200 Subject: Code cleanup for Tramp's yubikey integration * lisp/net/tramp-sh.el (tramp-actions-before-shell) (tramp-actions-copy-out-of-band): Use `tramp-security-key-confirm-regexp'. * lisp/net/tramp.el (tramp-security-key-confirm-regexp): Rename from `tramp-yubikey-regexp'. Adapt docstring. (tramp-security-key-confirmed-regexp): New defcustom. (tramp-action-show-and-confirm-message): Redisplay. Use `tramp-security-key-confirmed-regexp'. --- lisp/net/tramp-sh.el | 4 ++-- lisp/net/tramp.el | 3 ++- 2 files changed, 4 insertions(+), 3 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 7cf90b96612..e7d2634c587 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -519,7 +519,7 @@ shell from reading its init file." (tramp-yn-prompt-regexp tramp-action-yn) (tramp-terminal-prompt-regexp tramp-action-terminal) (tramp-antispoof-regexp tramp-action-confirm-message) - (tramp-yubikey-regexp tramp-action-show-and-confirm-message) + (tramp-security-key-confirm-regexp tramp-action-show-and-confirm-message) (tramp-process-alive-regexp tramp-action-process-alive)) "List of pattern/action pairs. Whenever a pattern matches, the corresponding action is performed. @@ -537,7 +537,7 @@ corresponding PATTERN matches, the ACTION function is called.") '((tramp-password-prompt-regexp tramp-action-password) (tramp-wrong-passwd-regexp tramp-action-permission-denied) (tramp-copy-failed-regexp tramp-action-permission-denied) - (tramp-yubikey-regexp tramp-action-show-and-confirm-message) + (tramp-security-key-confirm-regexp tramp-action-show-and-confirm-message) (tramp-process-alive-regexp tramp-action-out-of-band)) "List of pattern/action pairs. This list is used for copying/renaming with out-of-band methods. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 959a0e74352..21757465fad 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -4691,10 +4691,11 @@ Wait, until the connection buffer changes." (goto-char (point-min)) (tramp-check-for-regexp proc tramp-process-action-regexp) (with-temp-message (replace-regexp-in-string "[\r\n]" "" (match-string 0)) + (redisplay 'force) ;; Hide message in buffer. (narrow-to-region (point-max) (point-max)) ;; Wait for new output. - (tramp-wait-for-regexp proc 30 ".")) + (tramp-wait-for-regexp proc 30 tramp-security-key-confirmed-regexp)) ;; Reenable the timers. (with-timeout-unsuspend stimers))) t) -- cgit v1.2.3 From 1572464b9271472b8d7a36b698541afc59b44870 Mon Sep 17 00:00:00 2001 From: Mattias EngdegĂ„rd Date: Tue, 10 Aug 2021 15:05:51 +0200 Subject: Tramp string-search and string-replace compatibility functions Add a `string-search` compatibility function for use in Tramp with Emacs version prior to 28, and fix the existing `string-replace` compatibility function so that it uses the right semantics. * lisp/net/tramp-compat.el (tramp-compat-string-replace): Use case-sensitive matching and literal replacement. (tramp-compat-string-search): New function. * lisp/net/tramp-gvfs.el (tramp-gvfs-handle-file-name-all-completions): * lisp/net/tramp-sh.el (tramp-sh-handle-file-name-all-completions) (tramp-do-copy-or-rename-file-out-of-band) (tramp-sh-handle-make-process, tramp-sh-handle-process-file): * lisp/net/tramp.el (tramp-handle-make-process): Use `tramp-compat-string-search` instead of `string-match-p`. --- lisp/net/tramp-compat.el | 12 +++++++++++- lisp/net/tramp-gvfs.el | 2 +- lisp/net/tramp-sh.el | 9 +++++---- lisp/net/tramp.el | 4 ++-- 4 files changed, 19 insertions(+), 8 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 6e464073379..b713d5eae82 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -351,7 +351,17 @@ A nil value for either argument stands for the current time." (if (fboundp 'string-replace) #'string-replace (lambda (fromstring tostring instring) - (replace-regexp-in-string (regexp-quote fromstring) tostring instring)))) + (let ((case-fold-search nil)) + (replace-regexp-in-string + (regexp-quote fromstring) tostring instring t t))))) + +;; Function `string-search' is new in Emacs 28.1. +(defalias 'tramp-compat-string-search + (if (fboundp 'string-search) + #'string-search + (lambda (needle haystack &optional start-pos) + (let ((case-fold-search nil)) + (string-match-p (regexp-quote needle) haystack start-pos))))) ;; Function `make-lock-file-name' is new in Emacs 28.1. (defalias 'tramp-compat-make-lock-file-name diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index eff14a2912f..e4f54cf4c46 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -1401,7 +1401,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (defun tramp-gvfs-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (unless (string-match-p "/" filename) + (unless (tramp-compat-string-search "/" filename) (all-completions filename (with-parsed-tramp-file-name (expand-file-name directory) nil diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index e7d2634c587..c3b8df9e579 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1740,7 +1740,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; files. (defun tramp-sh-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (unless (string-match-p "/" filename) + (unless (tramp-compat-string-search "/" filename) (all-completions filename (with-parsed-tramp-file-name (expand-file-name directory) nil @@ -2309,7 +2309,8 @@ The method used must be an out-of-band method." copy-args (tramp-compat-flatten-tree (mapcar - (lambda (x) (if (string-match-p " " x) (split-string x) x)) + (lambda (x) (if (tramp-compat-string-search " " x) + (split-string x) x)) copy-args)) copy-env (apply #'tramp-expand-args v 'tramp-copy-env spec) remote-copy-program @@ -2828,7 +2829,7 @@ implementation will be used." (env (dolist (elt (cons prompt process-environment) env) (or (member elt (default-toplevel-value 'process-environment)) - (if (string-match-p "=" elt) + (if (tramp-compat-string-search "=" elt) (setq env (append env `(,elt))) (setq uenv (cons elt uenv)))))) (env (setenv-internal @@ -3039,7 +3040,7 @@ implementation will be used." ;; We use as environment the difference to toplevel `process-environment'. (dolist (elt process-environment) (or (member elt (default-toplevel-value 'process-environment)) - (if (string-match-p "=" elt) + (if (tramp-compat-string-search "=" elt) (setq env (append env `(,elt))) (setq uenv (cons elt uenv))))) (setenv-internal env "INSIDE_EMACS" (tramp-inside-emacs) 'keep) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 3a392dd5f8a..fd426960fd2 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -4130,14 +4130,14 @@ substitution. SPEC-LIST is a list of char/value pairs used for (generate-new-buffer tramp-temp-buffer-name))) (env (mapcar (lambda (elt) - (when (string-match-p "=" elt) elt)) + (when (tramp-compat-string-search "=" elt) elt)) tramp-remote-process-environment)) ;; We use as environment the difference to toplevel ;; `process-environment'. (env (dolist (elt process-environment env) (when (and - (string-match-p "=" elt) + (tramp-compat-string-search "=" elt) (not (member elt (default-toplevel-value 'process-environment)))) -- cgit v1.2.3 From 244acc5a057b0d6ff03754af14d71808b6f20233 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Wed, 11 Aug 2021 15:34:43 +0200 Subject: Replace some `string-match-p' calls in Tramp * lisp/net/tramp.el (tramp-debug-message, tramp-set-completion-function) (tramp-get-completion-methods, tramp-get-completion-user-host): * lisp/net/tramp-adb.el (tramp-adb-handle-make-process): * lisp/net/tramp-sh.el (tramp-sh-handle-make-process) (tramp-open-connection-setup-interactive-shell) (tramp-convert-file-attributes): Use `string-prefix-p'. * lisp/net/tramp.el (tramp-dissect-file-name) (tramp-progress-reporter-update, tramp-handle-insert-directory): * lisp/net/tramp-cache.el (tramp-get-hash-table) (tramp-flush-directory-properties): * lisp/net/tramp-cmds.el (tramp-append-tramp-buffers): * lisp/net/tramp-sh.el (tramp-sh-handle-insert-directory) (tramp-call-local-coding-command, tramp-get-inline-coding): * lisp/net/tramp-smb.el (tramp-smb-handle-file-attributes) (tramp-smb-handle-file-name-all-completions) (tramp-smb-handle-file-writable-p) (tramp-smb-handle-insert-directory) (tramp-smb-handle-start-file-process, ) (tramp-smb-read-file-entry): Use `tramp-compat-string-search'. --- lisp/net/tramp-adb.el | 2 +- lisp/net/tramp-cache.el | 6 +++--- lisp/net/tramp-cmds.el | 2 +- lisp/net/tramp-sh.el | 37 +++++++++++++++++++------------------ lisp/net/tramp-smb.el | 26 +++++++++++++------------- lisp/net/tramp.el | 25 ++++++++++--------------- 6 files changed, 47 insertions(+), 51 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 5e0accc142a..2f84312f077 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -1065,7 +1065,7 @@ implementation will be used." p)))) ;; Save exit. - (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (if (string-prefix-p tramp-temp-buffer-name (buffer-name)) (ignore-errors (set-process-buffer (tramp-get-connection-process v) nil) (kill-buffer (current-buffer))) diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index fcfad012ec8..5a00915f4f0 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -125,7 +125,7 @@ If KEY is `tramp-cache-undefined', don't create anything, and return nil." (puthash key (make-hash-table :test #'equal) tramp-cache-data))) (when (tramp-file-name-p key) (dolist (elt tramp-connection-properties) - (when (string-match-p + (when (tramp-compat-string-search (or (nth 0 elt) "") (tramp-make-tramp-file-name key 'noloc 'nohop)) (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) @@ -268,8 +268,8 @@ Remove also properties of all files in subdirectories." (dolist (key (hash-table-keys tramp-cache-data)) (when (and (tramp-file-name-p key) (stringp (tramp-file-name-localname key)) - (string-match-p (regexp-quote directory) - (tramp-file-name-localname key))) + (tramp-compat-string-search + directory (tramp-file-name-localname key))) (remhash key tramp-cache-data))) ;; Remove file properties of symlinks. (when (and (stringp truename) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index d30d22021a5..6278fd302af 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -672,7 +672,7 @@ buffer in your bug report. (insert "\nload-path shadows:\n==================\n") (ignore-errors (mapc - (lambda (x) (when (string-match-p "tramp" x) (insert x "\n"))) + (lambda (x) (when (tramp-compat-string-search "tramp" x) (insert x "\n"))) (split-string (list-load-path-shadows t) "\n"))) ;; Append buffers only when we are in message mode. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index c3b8df9e579..fad07d87c51 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2603,8 +2603,8 @@ The method used must be an out-of-band method." (save-restriction (narrow-to-region beg-marker end-marker) ;; Some busyboxes are reluctant to discard colors. - (unless - (string-match-p "color" (tramp-get-connection-property v "ls" "")) + (unless (tramp-compat-string-search + "color" (tramp-get-connection-property v "ls" "")) (goto-char (point-min)) (while (re-search-forward tramp-display-escape-sequence-regexp nil t) (replace-match ""))) @@ -2958,7 +2958,7 @@ implementation will be used." p))) ;; Save exit. - (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (if (string-prefix-p tramp-temp-buffer-name (buffer-name)) (ignore-errors (set-process-buffer p nil) (kill-buffer (current-buffer))) @@ -4309,7 +4309,7 @@ process to set up. VEC specifies the connection." ;; Use MULE to select the right EOL convention for communicating ;; with the process. (let ((cs (or (and (memq 'utf-8-hfs (coding-system-list)) - (string-match-p "^Darwin" uname) + (string-prefix-p "Darwin" uname) (cons 'utf-8-hfs 'utf-8-hfs)) (and (memq 'utf-8 (coding-system-list)) (string-match-p "utf-?8" (tramp-get-remote-locale vec)) @@ -4322,7 +4322,7 @@ process to set up. VEC specifies the connection." cs-encode (or (cdr cs) 'undecided) cs-encode (coding-system-change-eol-conversion - cs-encode (if (string-match-p "^Darwin" uname) 'mac 'unix))) + cs-encode (if (string-prefix-p "Darwin" uname) 'mac 'unix))) (tramp-send-command vec "(echo foo ; echo bar)" t) (goto-char (point-min)) (when (search-forward "\r" nil t) @@ -4372,7 +4372,7 @@ process to set up. VEC specifies the connection." ;; IRIX64 bash expands "!" even when in single quotes. This ;; destroys our shell functions, we must disable it. See ;; . - (when (string-match-p "^IRIX64" uname) + (when (string-prefix-p "IRIX64" uname) (tramp-send-command vec "set +H" t)) ;; Disable tab expansion. @@ -4628,12 +4628,12 @@ means standard output and thus the current buffer), or nil (which means discard it)." (tramp-call-process nil tramp-encoding-shell - (when (and input (not (string-match-p "%s" cmd))) input) + (when (and input (not (tramp-compat-string-search "%s" cmd))) input) (if (eq output t) t nil) nil tramp-encoding-command-switch (concat - (if (string-match-p "%s" cmd) (format cmd input) cmd) + (if (tramp-compat-string-search "%s" cmd) (format cmd input) cmd) (if (stringp output) (concat " >" output) "")))) (defconst tramp-inline-compress-commands @@ -5223,7 +5223,7 @@ Return ATTR." (when (stringp (car attr)) (aset (nth 8 attr) 0 ?l))) ;; Convert directory indication bit. - (when (string-match-p "^d" (nth 8 attr)) + (when (string-prefix-p "d" (nth 8 attr)) (setcar attr t)) ;; Convert symlink from `tramp-do-file-attributes-with-stat'. ;; Decode also multibyte string. @@ -5803,12 +5803,13 @@ function cell is returned to be applied on a buffer." (with-tramp-connection-property (tramp-get-process vec) prop (tramp-find-inline-encoding vec) (tramp-get-connection-property (tramp-get-process vec) prop nil))) - (prop1 (if (string-match-p "encoding" prop) + (prop1 (if (tramp-compat-string-search "encoding" prop) "inline-compress" "inline-decompress")) compress) ;; The connection property might have been cached. So we must ;; send the script to the remote side - maybe. - (when (and coding (symbolp coding) (string-match-p "remote" prop)) + (when (and coding (symbolp coding) + (tramp-compat-string-search "remote" prop)) (let ((name (symbol-name coding))) (while (string-match "-" name) (setq name (replace-match "_" nil t name))) @@ -5820,7 +5821,7 @@ function cell is returned to be applied on a buffer." ;; Return the value. (cond ((and compress (symbolp coding)) - (if (string-match-p "decompress" prop1) + (if (tramp-compat-string-search "decompress" prop1) `(lambda (beg end) (,coding beg end) (let ((coding-system-for-write 'binary) @@ -5839,16 +5840,16 @@ function cell is returned to be applied on a buffer." (,coding (point-min) (point-max))))) ((symbolp coding) coding) - ((and compress (string-match-p "decoding" prop)) + ((and compress (tramp-compat-string-search "decoding" prop)) (format ;; Windows shells need the program file name after ;; the pipe symbol be quoted if they use forward ;; slashes as directory separators. (cond - ((and (string-match-p "local" prop) + ((and (tramp-compat-string-search "local" prop) (eq system-type 'windows-nt)) "(%s | \"%s\")") - ((string-match-p "local" prop) "(%s | %s)") + ((tramp-compat-string-search "local" prop) "(%s | %s)") (t "(%s | %s >%%s)")) coding compress)) (compress @@ -5856,14 +5857,14 @@ function cell is returned to be applied on a buffer." ;; Windows shells need the program file name after ;; the pipe symbol be quoted if they use forward ;; slashes as directory separators. - (if (and (string-match-p "local" prop) + (if (and (tramp-compat-string-search "local" prop) (eq system-type 'windows-nt)) "(%s <%%s | \"%s\")" "(%s <%%s | %s)") compress coding)) - ((string-match-p "decoding" prop) + ((tramp-compat-string-search "decoding" prop) (cond - ((string-match-p "local" prop) (format "%s" coding)) + ((tramp-compat-string-search "local" prop) (format "%s" coding)) (t (format "%s >%%s" coding)))) (t (format "%s <%%s" coding))))))) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 3d5be61d3f0..69372449172 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -849,7 +849,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Check result. (when entry - (list (and (string-match-p "d" (nth 1 entry)) + (list (and (tramp-compat-string-search "d" (nth 1 entry)) t) ;0 file type -1 ;1 link count uid ;2 uid @@ -982,7 +982,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (mapcar (lambda (x) (list - (if (string-match-p "d" (nth 1 x)) + (if (tramp-compat-string-search "d" (nth 1 x)) (file-name-as-directory (nth 0 x)) (nth 0 x)))) (tramp-smb-get-file-entries directory))))))) @@ -1021,7 +1021,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (defun tramp-smb-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." (if (file-exists-p filename) - (string-match-p + (tramp-compat-string-search "w" (or (tramp-compat-file-attribute-modes (file-attributes filename)) "")) (let ((dir (file-name-directory filename))) @@ -1076,9 +1076,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Check for matching entries. (mapcar (lambda (x) - (when (string-match-p - (format "^%s" base) (nth 0 x)) - x)) + (when (string-match-p (format "^%s" base) (nth 0 x)) x)) entries) ;; We just need the only and only entry FILENAME. (list (assoc base entries))))) @@ -1088,14 +1086,14 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (sort entries (lambda (x y) - (if (string-match-p "t" switches) + (if (tramp-compat-string-search "t" switches) ;; Sort by date. (time-less-p (nth 3 y) (nth 3 x)) ;; Sort by name. (string-lessp (nth 0 x) (nth 0 y)))))) ;; Handle "-F" switch. - (when (string-match-p "F" switches) + (when (tramp-compat-string-search "F" switches) (mapc (lambda (x) (unless (zerop (length (car x))) @@ -1124,7 +1122,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (expand-file-name (nth 0 x) (file-name-directory filename)) 'string))))) - (when (string-match-p "l" switches) + (when (tramp-compat-string-search "l" switches) (insert (format "%10s %3d %-8s %-8s %8s %s " @@ -1153,7 +1151,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (put-text-property start (point) 'dired-filename t)) ;; Insert symlink. - (when (and (string-match-p "l" switches) + (when (and (tramp-compat-string-search "l" switches) (stringp (tramp-compat-file-attribute-type attr))) (insert " -> " (tramp-compat-file-attribute-type attr)))) @@ -1551,7 +1549,7 @@ component is used as the target of the symlink." ;; Save exit. (with-current-buffer (tramp-get-connection-buffer v) - (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (if (tramp-compat-string-search tramp-temp-buffer-name (buffer-name)) (progn (set-process-buffer (tramp-get-connection-process v) nil) (kill-buffer (current-buffer))) @@ -1857,10 +1855,12 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." mode (or (match-string 1 line) "") mode (format "%s%s" - (if (string-match-p "D" mode) "d" "-") + (if (tramp-compat-string-search "D" mode) "d" "-") (mapconcat (lambda (_x) "") " " - (concat "r" (if (string-match-p "R" mode) "-" "w") "x"))) + (format + "r%sx" + (if (tramp-compat-string-search "R" mode) "-" "w")))) line (substring line 0 -6)) (cl-return)) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index fd426960fd2..6fc0ac8e1ef 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1625,7 +1625,8 @@ default values are used." (setq v (tramp-dissect-hop-name hop) hop (and hop (tramp-make-tramp-hop-name v)))) (let ((tramp-default-host - (or (and v (not (string-match-p "%h" (tramp-file-name-host v))) + (or (and v (not (tramp-compat-string-search + "%h" (tramp-file-name-host v))) (tramp-file-name-host v)) tramp-default-host))) (setq method (tramp-find-method method user host) @@ -1973,7 +1974,7 @@ ARGUMENTS to actually emit the message (if applicable)." (if (not btf) (setq fn "") (and (symbolp btf) (setq fn (symbol-name btf)) - (or (not (string-match-p "^tramp" fn)) + (or (not (string-prefix-p "tramp" fn)) (get btf 'tramp-suppress-trace)) (setq fn nil)) (setq btn (1+ btn)))) @@ -2225,7 +2226,7 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', "Report progress of an operation for Tramp." (let* ((parameters (cdr reporter)) (message (aref parameters 3))) - (when (string-match-p message (or (current-message) "")) + (when (tramp-compat-string-search message (or (current-message) "")) (tramp-compat-progress-reporter-update reporter value suffix)))) (defmacro with-tramp-progress-reporter (vec level message &rest body) @@ -2339,7 +2340,7 @@ Example: (unless (and (functionp (nth 0 (car v))) (cond ;; Windows registry. - ((string-match-p "^HKEY_CURRENT_USER" (nth 1 (car v))) + ((string-prefix-p "HKEY_CURRENT_USER" (nth 1 (car v))) (and (memq system-type '(cygwin windows-nt)) (zerop (tramp-call-process @@ -2998,8 +2999,7 @@ remote host and localname (filename on remote host)." "Return all method completions for PARTIAL-METHOD." (mapcar (lambda (method) - (and method - (string-match-p (concat "^" (regexp-quote partial-method)) method) + (and method (string-prefix-p partial-method method) (tramp-completion-make-tramp-file-name method nil nil nil))) (mapcar #'car tramp-methods))) @@ -3011,8 +3011,7 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." (cond ((and partial-user partial-host) - (if (and host - (string-match-p (concat "^" (regexp-quote partial-host)) host) + (if (and host (string-prefix-p partial-host host) (string-equal partial-user (or user partial-user))) (setq user partial-user) (setq user nil @@ -3020,16 +3019,12 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." (partial-user (setq host nil) - (unless - (and user - (string-match-p (concat "^" (regexp-quote partial-user)) user)) + (unless (and user (string-prefix-p partial-user user)) (setq user nil))) (partial-host (setq user nil) - (unless - (and host - (string-match-p (concat "^" (regexp-quote partial-host)) host)) + (unless (and host (string-prefix-p partial-host host)) (setq host nil))) (t (setq user nil @@ -3707,7 +3702,7 @@ User is always nil." (list filename switches wildcard full-directory-p)) ;; `ls-lisp' always returns full listings. We must remove ;; superfluous parts. - (unless (string-match-p "l" switches) + (unless (tramp-compat-string-search "l" switches) (save-excursion (goto-char (point-min)) (while (setq start -- cgit v1.2.3 From 5d50acd0a61f70db4069457a5f14fb1a9b0f7f7c Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Thu, 12 Aug 2021 20:09:48 +0200 Subject: Improve connection type `pipe' for remote processes * doc/misc/tramp.texi (Remote processes): New subsection "Remote process connection type". * lisp/net/tramp-adb.el (tramp-adb-handle-make-process): Use `tramp-process-connection-type' as default connection type. Improve check for `:connection-type'. * lisp/net/tramp-sh.el (tramp-sh-handle-make-process): Use `tramp-process-connection-type' as default connection type. Improve check for `:connection-type'. Send "stty -icrnl" when connection type is a pipe. * lisp/net/tramp.el (tramp-process-connection-type): Allow all possible values. (tramp-handle-make-process): Use `tramp-process-connection-type' as default connection type. Improve check for `:connection-type'. * test/lisp/net/tramp-tests.el (tramp-test30-make-process): Extend test. --- doc/misc/tramp.texi | 26 ++++++++++++++++++++++++++ lisp/net/tramp-adb.el | 7 +++++-- lisp/net/tramp-sh.el | 10 ++++++++-- lisp/net/tramp.el | 11 +++++++---- test/lisp/net/tramp-tests.el | 40 +++++++++++++++++++++++++++++++++++++++- 5 files changed, 85 insertions(+), 9 deletions(-) (limited to 'lisp/net/tramp-sh.el') diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 38c20de62a2..bd9bd998dfb 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -3734,6 +3734,32 @@ To open @command{powershell} as a remote shell, use this: @end lisp +@subsection Remote process connection type +@vindex process-connection-type +@cindex tramp-process-connection-type + +Asynchronous processes differ in the way, whether they use a pseudo +tty, or not. This is controlled by the variable +@code{process-connection-type}, which can be @code{t} or @code{pty} +(use a pseudo tty), or @code{nil} or @code{pipe} (don't use it). +@value{tramp} is based on running shells on the remote host, which +require a pseudo tty. Therefore, it declares the variable +@code{tramp-process-connection-type}, which carries this information +for remote processes. Per default, its value is @code{t}. The name +of the remote pseudo tty is returned by the function +@code{process-tty-name}. + +If a remote process, started by @code{start-file-process}, shouldn't +use a pseudo tty, this is emulated by let-binding this variable to +@code{nil} or @code{pipe}. There is still a pseudo tty for the +started process, but some terminal properties are changed, like +suppressing translation of carriage return characters into newline. + +The function @code{make-process} allows an explicit setting by the +@code{:connection-type} keyword. If this keyword is not used, the +value of @code{tramp-process-connection-type} is applied instead. + + @anchor{Improving performance of asynchronous remote processes} @subsection Improving performance of asynchronous remote processes @cindex Asynchronous remote processes diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 2f84312f077..c16e232c6d5 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -924,7 +924,10 @@ implementation will be used." (command (plist-get args :command)) (coding (plist-get args :coding)) (noquery (plist-get args :noquery)) - (connection-type (plist-get args :connection-type)) + (connection-type + (if (plist-member args :connection-type) + (plist-get args :connection-type) + tramp-process-connection-type)) (filter (plist-get args :filter)) (sentinel (plist-get args :sentinel)) (stderr (plist-get args :stderr))) @@ -940,7 +943,7 @@ implementation will be used." (memq (car coding) coding-system-list) (memq (cdr coding) coding-system-list))) (signal 'wrong-type-argument (list #'symbolp coding))) - (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (unless (memq connection-type '(nil pipe t pty)) (signal 'wrong-type-argument (list #'symbolp connection-type))) (unless (or (null filter) (functionp filter)) (signal 'wrong-type-argument (list #'functionp filter))) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index fad07d87c51..f00434c1468 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -2752,7 +2752,10 @@ implementation will be used." (command (plist-get args :command)) (coding (plist-get args :coding)) (noquery (plist-get args :noquery)) - (connection-type (plist-get args :connection-type)) + (connection-type + (if (plist-member args :connection-type) + (plist-get args :connection-type) + tramp-process-connection-type)) (filter (plist-get args :filter)) (sentinel (plist-get args :sentinel)) (stderr (plist-get args :stderr))) @@ -2768,7 +2771,7 @@ implementation will be used." (memq (car coding) coding-system-list) (memq (cdr coding) coding-system-list))) (signal 'wrong-type-argument (list #'symbolp coding))) - (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (unless (memq connection-type '(nil pipe t pty)) (signal 'wrong-type-argument (list #'symbolp connection-type))) (unless (or (null filter) (functionp filter)) (signal 'wrong-type-argument (list #'functionp filter))) @@ -2916,6 +2919,9 @@ implementation will be used." (setq p (tramp-get-connection-process v)) (process-put p 'remote-pid pid) (tramp-set-connection-property p "remote-pid" pid)) + ;; Disable carriage return to newline translation. + (when (memq connection-type '(nil pipe)) + (tramp-send-command v "stty -icrnl")) ;; `tramp-maybe-open-connection' and ;; `tramp-send-command-and-read' could have ;; trashed the connection buffer. Remove this. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 6fc0ac8e1ef..83df05c24b7 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1264,14 +1264,14 @@ this variable to be set as well." :type '(choice (const nil) integer)) ;; Logging in to a remote host normally requires obtaining a pty. But -;; Emacs on macOS has process-connection-type set to nil by default, +;; Emacs on macOS has `process-connection-type' set to nil by default, ;; so on those systems Tramp doesn't obtain a pty. Here, we allow ;; for an override of the system default. (defcustom tramp-process-connection-type t "Overrides `process-connection-type' for connections from Tramp. Tramp binds `process-connection-type' to the value given here before opening a connection to a remote host." - :type '(choice (const nil) (const t) (const pty))) + :type '(choice (const nil) (const t) (const pipe) (const pty))) (defcustom tramp-connection-timeout 60 "Defines the max time to wait for establishing a connection (in seconds). @@ -4093,7 +4093,10 @@ substitution. SPEC-LIST is a list of char/value pairs used for (command (plist-get args :command)) (coding (plist-get args :coding)) (noquery (plist-get args :noquery)) - (connection-type (plist-get args :connection-type)) + (connection-type + (if (plist-member args :connection-type) + (plist-get args :connection-type) + tramp-process-connection-type)) (filter (plist-get args :filter)) (sentinel (plist-get args :sentinel)) (stderr (plist-get args :stderr))) @@ -4109,7 +4112,7 @@ substitution. SPEC-LIST is a list of char/value pairs used for (memq (car coding) coding-system-list) (memq (cdr coding) coding-system-list))) (signal 'wrong-type-argument (list #'symbolp coding))) - (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (unless (memq connection-type '(nil pipe t pty)) (signal 'wrong-type-argument (list #'symbolp connection-type))) (unless (or (null filter) (functionp filter)) (signal 'wrong-type-argument (list #'functionp filter))) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 052c03029fd..3008861f22b 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -4749,7 +4749,45 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Cleanup. (ignore-errors (delete-process proc)) - (ignore-errors (delete-file tmp-name))))))) + (ignore-errors (delete-file tmp-name)))) + + ;; Process connection type. + (when (and (tramp--test-sh-p) + ;; `executable-find' has changed the number of + ;; parameters in Emacs 27.1, so we use `apply' for + ;; older Emacsen. + (ignore-errors + (with-no-warnings + (apply #'executable-find '("hexdump" remote))))) + (dolist (connection-type '(nil pipe t pty)) + (unwind-protect + (with-temp-buffer + (setq proc + (with-no-warnings + (make-process + :name (format "test7-%s" connection-type) + :buffer (current-buffer) + :connection-type connection-type + :command '("hexdump" "-v" "-e" "/1 \"%02X\n\"") + :file-handler t))) + (should (processp proc)) + (should (equal (process-status proc) 'run)) + (process-send-string proc "foo\r\n") + (process-send-eof proc) + ;; Read output. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (< (- (point-max) (point-min)) + (length "66\n6F\n6F\n0D\n0A\n")) + (while (accept-process-output proc 0 nil t)))) + (should + (string-match-p + (if (memq connection-type '(nil pipe)) + "66\n6F\n6F\n0D\n0A\n" + "66\n6F\n6F\n0A\n0A\n") + (buffer-string)))) + + ;; Cleanup. + (ignore-errors (delete-process proc)))))))) (tramp--test--deftest-direct-async-process tramp-test30-make-process "Check direct async `make-process'.") -- cgit v1.2.3