diff options
Diffstat (limited to 'lisp/net')
61 files changed, 9040 insertions, 6711 deletions
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index f400c562939..b0a1e1799f5 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -1,4 +1,4 @@ -;;; ange-ftp.el --- transparent FTP support for GNU Emacs +;;; ange-ftp.el --- transparent FTP support for GNU Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1989-1996, 1998, 2000-2019 Free Software Foundation, ;; Inc. @@ -1168,7 +1168,7 @@ only return the directory part of FILE." (ange-ftp-parse-netrc) (catch 'found-one (maphash - (lambda (host val) + (lambda (host _val) (if (ange-ftp-lookup-passwd host user) (throw 'found-one host))) ange-ftp-user-hashtable) (save-match-data @@ -1361,11 +1361,13 @@ only return the directory part of FILE." (ange-ftp-real-expand-file-name ange-ftp-netrc-filename))) (setq attr (ange-ftp-real-file-attributes file))) (if (and attr ; file exists. - (not (equal (nth 5 attr) ange-ftp-netrc-modtime))) ; file changed + (not (equal (file-attribute-modification-time attr) + ange-ftp-netrc-modtime))) ; file changed (save-match-data (if (or ange-ftp-disable-netrc-security-check - (and (eq (nth 2 attr) (user-uid)) ; Same uids. - (string-match ".r..------" (nth 8 attr)))) + (and (eq (file-attribute-user-id attr) (user-uid)) ; Same uids. + (string-match ".r..------" + (file-attribute-modes attr)))) (with-current-buffer ;; we are cheating a bit here. I'm trying to do the equivalent ;; of find-file on the .netrc file, but then nuke it afterwards. @@ -1389,7 +1391,8 @@ only return the directory part of FILE." (ange-ftp-message "%s either not owned by you or badly protected." ange-ftp-netrc-filename) (sit-for 1)) - (setq ange-ftp-netrc-modtime (nth 5 attr)))))) + (setq ange-ftp-netrc-modtime + (file-attribute-modification-time attr)))))) ;; Return a list of prefixes of the form 'user@host:' to be used when ;; completion is done in the root directory. @@ -1399,14 +1402,14 @@ only return the directory part of FILE." (save-match-data (let (res) (maphash - (lambda (key value) + (lambda (key _value) (if (string-match "\\`[^/]*\\(/\\).*\\'" key) (let ((host (substring key 0 (match-beginning 1))) (user (substring key (match-end 1)))) (push (concat user "@" host ":") res)))) ange-ftp-passwd-hashtable) (maphash - (lambda (host user) (push (concat host ":") res)) + (lambda (host _user) (push (concat host ":") res)) ange-ftp-user-hashtable) (or res (list nil))))) @@ -1684,7 +1687,7 @@ good, skip, fatal, or unknown." ange-ftp-process-result ange-ftp-process-result-line))))))) -(defun ange-ftp-process-sentinel (proc str) +(defun ange-ftp-process-sentinel (proc _str) "When FTP process changes state, nuke all file-entries in cache." (let ((name (process-name proc))) (when (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)\\*" name) @@ -1733,7 +1736,7 @@ good, skip, fatal, or unknown." (defvar ange-ftp-gwp-running t) (defvar ange-ftp-gwp-status nil) -(defun ange-ftp-gwp-sentinel (proc str) +(defun ange-ftp-gwp-sentinel (_proc _str) (setq ange-ftp-gwp-running nil)) (defun ange-ftp-gwp-filter (proc str) @@ -1873,7 +1876,7 @@ been queued with no result. CONT will still be called, however." (interactive "sHost: ") (if ange-ftp-nslookup-program (let ((default-directory - (if (file-accessible-directory-p default-directory) + (if (ange-ftp-real-file-accessible-directory-p default-directory) default-directory exec-directory)) ;; It would be nice to make process-connection-type nil, @@ -1916,7 +1919,7 @@ on the gateway machine to do the FTP instead." ;; default-directory. (file-name-handler-alist) (default-directory - (if (file-accessible-directory-p default-directory) + (if (ange-ftp-real-file-accessible-directory-p default-directory) default-directory exec-directory)) proc) @@ -1986,7 +1989,7 @@ on the gateway machine to do the FTP instead." (make-local-variable 'comint-password-prompt-regexp) ;; This is a regexp that can't match anything. ;; ange-ftp has its own ways of handling passwords. - (setq comint-password-prompt-regexp "\\`a\\`") + (setq comint-password-prompt-regexp regexp-unmatchable) (make-local-variable 'paragraph-start) (setq paragraph-start comint-prompt-regexp)) @@ -2676,7 +2679,7 @@ The main reason for this alist is to deal with file versions in VMS.") (defmacro ange-ftp-parse-filename () ;;Extract the filename from the current line of a dired-like listing. - `(save-match-data + '(save-match-data (let ((eol (progn (end-of-line) (point)))) (beginning-of-line) (if (re-search-forward directory-listing-before-filename-regexp eol t) @@ -2725,7 +2728,7 @@ The main reason for this alist is to deal with file versions in VMS.") ;; seem to believe in the F-switch (if (or (and symlink (string-match "@\\'" file)) (and directory (string-match "/\\'" file)) - (and executable (string-match "*\\'" file)) + (and executable (string-match "\\*\\'" file)) (and socket (string-match "=\\'" file))) (setq file (substring file 0 -1))))) (puthash file (or symlink directory) tbl) @@ -2758,7 +2761,7 @@ match subdirectories as well.") (defmacro ange-ftp-dl-parser () ;; Parse the current buffer, which is assumed to be a descriptive ;; listing, and return a hashtable. - `(let ((tbl (make-hash-table :test 'equal))) + '(let ((tbl (make-hash-table :test 'equal))) (while (not (eobp)) (puthash (buffer-substring (point) @@ -2868,7 +2871,6 @@ NO-ERROR, if a listing for DIRECTORY cannot be obtained." ;; 2. The syntax of FILE and DIR make it impossible that FILE could be a valid ;; subdirectory. This is of course an OS dependent judgment. -(defvar dired-local-variables-file) (defmacro ange-ftp-allow-child-lookup (dir file) `(not (let* ((efile ,file) ; expand once. @@ -2877,10 +2879,6 @@ NO-ERROR, if a listing for DIRECTORY cannot be obtained." (host-type (ange-ftp-host-type (car parsed)))) (or - ;; Deal with dired - (and (boundp 'dired-local-variables-file) ; in the dired-x package - (stringp dired-local-variables-file) - (string-equal dired-local-variables-file efile)) ;; No dots in dir names in vms. (and (eq host-type 'vms) (string-match "\\." efile)) @@ -3247,7 +3245,8 @@ system TYPE.") ;; tell the process filter what size the transfer will be. (let ((attr (file-attributes temp))) (if attr - (ange-ftp-set-xfer-size host user (nth 7 attr)))) + (ange-ftp-set-xfer-size host user + (file-attribute-size attr)))) ;; put or append the file. (let ((result (ange-ftp-send-cmd host user @@ -3373,6 +3372,13 @@ system TYPE.") (file-error nil)) (ange-ftp-real-file-symlink-p file))) +(defun ange-ftp-file-regular-p (file) + ;; Reuse Tramp's implementation. + (if (ange-ftp-ftp-name file) + (and (file-exists-p file) + (eq ?- (aref (file-attribute-modes (file-attributes file)) 0))) + (ange-ftp-real-file-regular-p file))) + (defun ange-ftp-file-exists-p (name) (setq name (expand-file-name name)) (if (ange-ftp-ftp-name name) @@ -3404,6 +3410,10 @@ system TYPE.") file-ent)) (ange-ftp-real-file-directory-p name))) +(defun ange-ftp-file-accessible-directory-p (name) + (and (file-directory-p name) + (file-readable-p name))) + (defun ange-ftp-directory-files (directory &optional full match &rest v19-args) (setq directory (expand-file-name directory)) @@ -3441,9 +3451,9 @@ system TYPE.") (let ((part (ange-ftp-get-file-part file)) (files (ange-ftp-get-files (file-name-directory file)))) (if (ange-ftp-hash-entry-exists-p part files) - (let ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (name (nth 2 parsed)) + (let (;; (host (nth 0 parsed)) + ;; (user (nth 1 parsed)) + ;; (name (nth 2 parsed)) (dirp (gethash part files)) (inode (gethash file ange-ftp-inodes-hashtable))) (unless inode @@ -3475,8 +3485,8 @@ system TYPE.") (let ((f1-parsed (ange-ftp-ftp-name f1)) (f2-parsed (ange-ftp-ftp-name f2))) (if (or f1-parsed f2-parsed) - (let ((f1-mt (nth 5 (file-attributes f1))) - (f2-mt (nth 5 (file-attributes f2)))) + (let ((f1-mt (file-attribute-modification-time (file-attributes f1))) + (f2-mt (file-attribute-modification-time (file-attributes f2)))) (cond ((null f1-mt) nil) ((null f2-mt) t) (t (time-less-p f2-mt f1-mt)))) @@ -3776,7 +3786,8 @@ so return the size on the remote host exactly. See RFC 3659." ;; tell the process filter what size the file is. (let ((attr (file-attributes (or temp2 filename)))) (if attr - (ange-ftp-set-xfer-size t-host t-user (nth 7 attr)))) + (ange-ftp-set-xfer-size t-host t-user + (file-attribute-size attr)))) (ange-ftp-send-cmd t-host @@ -3829,7 +3840,7 @@ so return the size on the remote host exactly. See RFC 3659." (ange-ftp-call-cont cont result line))) (defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists - keep-date preserve-uid-gid + keep-date _preserve-uid-gid _preserve-selinux-context) (interactive "fCopy file: \nFCopy %s to file: \np") (ange-ftp-copy-file-internal filename @@ -4266,7 +4277,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") nil t nil - "-c" + shell-command-switch (format "compress -f -c < %s > %s" tmp1 tmp2)) (and ange-ftp-process-verbose (ange-ftp-message "Compressing %s...done" abbr)) @@ -4302,7 +4313,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") nil t nil - "-c" + shell-command-switch (format "uncompress -c < %s > %s" tmp1 tmp2)) (and ange-ftp-process-verbose (ange-ftp-message "Uncompressing %s...done" abbr)) @@ -4385,10 +4396,13 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (put 'directory-files-and-attributes 'ange-ftp 'ange-ftp-directory-files-and-attributes) (put 'file-directory-p 'ange-ftp 'ange-ftp-file-directory-p) +(put 'file-accessible-directory-p 'ange-ftp + 'ange-ftp-file-accessible-directory-p) (put 'file-writable-p 'ange-ftp 'ange-ftp-file-writable-p) (put 'file-readable-p 'ange-ftp 'ange-ftp-file-readable-p) (put 'file-executable-p 'ange-ftp 'ange-ftp-file-executable-p) (put 'file-symlink-p 'ange-ftp 'ange-ftp-file-symlink-p) +(put 'file-regular-p 'ange-ftp 'ange-ftp-file-regular-p) (put 'delete-file 'ange-ftp 'ange-ftp-delete-file) (put 'verify-visited-file-modtime 'ange-ftp 'ange-ftp-verify-visited-file-modtime) @@ -4427,6 +4441,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") ;; We can handle process-file in a restricted way (just for chown). ;; Nothing possible for `start-file-process'. +(put 'exec-path 'ange-ftp 'ignore) +(put 'make-process 'ange-ftp 'ignore) (put 'process-file 'ange-ftp 'ange-ftp-process-file) (put 'start-file-process 'ange-ftp 'ignore) (put 'shell-command 'ange-ftp 'ange-ftp-shell-command) @@ -4469,6 +4485,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (ange-ftp-run-real-handler 'directory-files-and-attributes args)) (defun ange-ftp-real-file-directory-p (&rest args) (ange-ftp-run-real-handler 'file-directory-p args)) +(defun ange-ftp-real-file-accessible-directory-p (&rest args) + (ange-ftp-run-real-handler 'file-accessible-directory-p args)) (defun ange-ftp-real-file-writable-p (&rest args) (ange-ftp-run-real-handler 'file-writable-p args)) (defun ange-ftp-real-file-readable-p (&rest args) @@ -4477,6 +4495,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (ange-ftp-run-real-handler 'file-executable-p args)) (defun ange-ftp-real-file-symlink-p (&rest args) (ange-ftp-run-real-handler 'file-symlink-p args)) +(defun ange-ftp-real-file-regular-p (&rest args) + (ange-ftp-run-real-handler 'file-regular-p args)) (defun ange-ftp-real-delete-file (&rest args) (ange-ftp-run-real-handler 'delete-file args)) (defun ange-ftp-real-verify-visited-file-modtime (&rest args) @@ -5199,7 +5219,7 @@ Other orders of $ and _ seem to all work just fine.") ";\\([0-9]+\\)$")) (version 0)) (maphash - (lambda (name val) + (lambda (name _val) (and (string-match regexp name) (setq version (max version diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index cc7c11e4391..6382e66f615 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -131,9 +131,36 @@ :group 'external :group 'comm) +(defvar browse-url--browser-defcustom-type + '(choice + (function-item :tag "Emacs W3" :value browse-url-w3) + (function-item :tag "eww" :value eww-browse-url) + (function-item :tag "Mozilla" :value browse-url-mozilla) + (function-item :tag "Firefox" :value browse-url-firefox) + (function-item :tag "Google Chrome" :value browse-url-chrome) + (function-item :tag "Chromium" :value browse-url-chromium) + (function-item :tag "Epiphany" :value browse-url-epiphany) + (function-item :tag "Conkeror" :value browse-url-conkeror) + (function-item :tag "Text browser in an xterm window" + :value browse-url-text-xterm) + (function-item :tag "Text browser in an Emacs window" + :value browse-url-text-emacs) + (function-item :tag "KDE" :value browse-url-kde) + (function-item :tag "Elinks" :value browse-url-elinks) + (function-item :tag "Specified by `Browse Url Generic Program'" + :value browse-url-generic) + (function-item :tag "Default Windows browser" + :value browse-url-default-windows-browser) + (function-item :tag "Default macOS browser" + :value browse-url-default-macosx-browser) + (function-item :tag "Default browser" + :value browse-url-default-browser) + (function :tag "Your own function") + (alist :tag "Regexp/function association list" + :key-type regexp :value-type function))) + ;;;###autoload -(defcustom browse-url-browser-function - 'browse-url-default-browser +(defcustom browse-url-browser-function 'browse-url-default-browser "Function to display the current buffer in a WWW browser. This is used by the `browse-url-at-point', `browse-url-at-mouse', and `browse-url-of-file' commands. @@ -143,34 +170,17 @@ If the value is not a function it should be a list of pairs associated with the first REGEXP which matches the current URL. The function is passed the URL and any other args of `browse-url'. The last regexp should probably be \".\" to specify a default browser." - :type '(choice - (function-item :tag "Emacs W3" :value browse-url-w3) - (function-item :tag "eww" :value eww-browse-url) - (function-item :tag "Mozilla" :value browse-url-mozilla) - (function-item :tag "Firefox" :value browse-url-firefox) - (function-item :tag "Google Chrome" :value browse-url-chrome) - (function-item :tag "Chromium" :value browse-url-chromium) - (function-item :tag "Epiphany" :value browse-url-epiphany) - (function-item :tag "Conkeror" :value browse-url-conkeror) - (function-item :tag "Text browser in an xterm window" - :value browse-url-text-xterm) - (function-item :tag "Text browser in an Emacs window" - :value browse-url-text-emacs) - (function-item :tag "KDE" :value browse-url-kde) - (function-item :tag "Elinks" :value browse-url-elinks) - (function-item :tag "Specified by `Browse Url Generic Program'" - :value browse-url-generic) - (function-item :tag "Default Windows browser" - :value browse-url-default-windows-browser) - (function-item :tag "Default macOS browser" - :value browse-url-default-macosx-browser) - (function-item :tag "Default browser" - :value browse-url-default-browser) - (function :tag "Your own function") - (alist :tag "Regexp/function association list" - :key-type regexp :value-type function)) - :version "24.1" - :group 'browse-url) + :type browse-url--browser-defcustom-type + :version "24.1") + +(defcustom browse-url-secondary-browser-function 'browse-url-default-browser + "Function used to launch an alternative browser. +This should usually be an external browser (that is, not eww or +w3m), used as the secondary browser choice, and is typically used +when giving a prefix argument to the URL-opening command (in +those modes that support this (for instance, eww/shr)." + :version "27.1" + :type browse-url--browser-defcustom-type) (defcustom browse-url-mailto-function 'browse-url-mail "Function to display mailto: links. @@ -181,8 +191,7 @@ be used instead." :type '(choice (function-item :tag "Emacs Mail" :value browse-url-mail) (function-item :tag "None" nil)) - :version "24.1" - :group 'browse-url) + :version "24.1") (defcustom browse-url-man-function 'browse-url-man "Function to display man: links." @@ -190,8 +199,28 @@ be used instead." (function-item :tag "Emacs Man" :value browse-url-man) (const :tag "None" nil) (function :tag "Other function")) - :version "26.1" - :group 'browse-url) + :version "26.1") + +(defcustom browse-url-button-regexp + (concat + "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|" + "nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)" + "\\(//[-a-z0-9_.]+:[0-9]*\\)?" + (let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]") + (punct "!?:;.,")) + (concat + "\\(?:" + ;; Match paired parentheses, e.g. in Wikipedia URLs: + ;; http://thread.gmane.org/47B4E3B2.3050402@gmail.com + "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" + "\\(?:" "[" chars punct "]+" "[" chars "]" "\\)?" + "\\|" + "[" chars punct "]+" "[" chars "]" + "\\)")) + "\\)") + "Regular expression that matches URLs." + :version "27.1" + :type 'regexp) (defcustom browse-url-netscape-program "netscape" ;; Info about netscape-remote from Karl Berry. @@ -202,15 +231,13 @@ The free program `netscape-remote' from up very much quicker than `netscape'. Reported to compile on a GNU system, given vroot.h from the same directory, with cc flags -DSTANDALONE -L/usr/X11R6/lib -lXmu -lX11." - :type 'string - :group 'browse-url) + :type 'string) (make-obsolete-variable 'browse-url-netscape-program nil "25.1") (defcustom browse-url-netscape-arguments nil "A list of strings to pass to Netscape as arguments." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (make-obsolete-variable 'browse-url-netscape-arguments nil "25.1") @@ -218,33 +245,27 @@ system, given vroot.h from the same directory, with cc flags "A list of strings to pass to Netscape when it starts up. Defaults to the value of `browse-url-netscape-arguments' at the time `browse-url' is loaded." - :type '(repeat (string :tag "Argument")) - - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (make-obsolete-variable 'browse-url-netscape-startup-arguments nil "25.1") (defcustom browse-url-browser-display nil "The X display for running the browser, if not same as Emacs's." - :type '(choice string (const :tag "Default" nil)) - :group 'browse-url) + :type '(choice string (const :tag "Default" nil))) (defcustom browse-url-mozilla-program "mozilla" "The name by which to invoke Mozilla." - :type 'string - :group 'browse-url) + :type 'string) (defcustom browse-url-mozilla-arguments nil "A list of strings to pass to Mozilla as arguments." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (defcustom browse-url-mozilla-startup-arguments browse-url-mozilla-arguments "A list of strings to pass to Mozilla when it starts up. Defaults to the value of `browse-url-mozilla-arguments' at the time `browse-url' is loaded." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (defcustom browse-url-firefox-program (let ((candidates '("icecat" "iceweasel" "firefox"))) @@ -252,20 +273,17 @@ Defaults to the value of `browse-url-mozilla-arguments' at the time (setq candidates (cdr candidates))) (or (car candidates) "firefox")) "The name by which to invoke Firefox or a variant of it." - :type 'string - :group 'browse-url) + :type 'string) (defcustom browse-url-firefox-arguments nil "A list of strings to pass to Firefox (or variant) as arguments." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (defcustom browse-url-firefox-startup-arguments browse-url-firefox-arguments "A list of strings to pass to Firefox (or variant) when it starts up. Defaults to the value of `browse-url-firefox-arguments' at the time `browse-url' is loaded." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (make-obsolete-variable 'browse-url-firefox-startup-arguments "it no longer has any effect." "24.5") @@ -277,14 +295,12 @@ Defaults to the value of `browse-url-firefox-arguments' at the time (or (car candidates) "chromium")) "The name by which to invoke the Chrome browser." :type 'string - :version "25.1" - :group 'browse-url) + :version "25.1") (defcustom browse-url-chrome-arguments nil "A list of strings to pass to Google Chrome as arguments." :type '(repeat (string :tag "Argument")) - :version "25.1" - :group 'browse-url) + :version "25.1") (defcustom browse-url-chromium-program (let ((candidates '("chromium" "chromium-browser"))) @@ -293,26 +309,22 @@ Defaults to the value of `browse-url-firefox-arguments' at the time (or (car candidates) "chromium")) "The name by which to invoke Chromium." :type 'string - :version "24.1" - :group 'browse-url) + :version "24.1") (defcustom browse-url-chromium-arguments nil "A list of strings to pass to Chromium as arguments." :type '(repeat (string :tag "Argument")) - :version "24.1" - :group 'browse-url) + :version "24.1") (defcustom browse-url-galeon-program "galeon" "The name by which to invoke Galeon." - :type 'string - :group 'browse-url) + :type 'string) (make-obsolete-variable 'browse-url-galeon-program nil "25.1") (defcustom browse-url-galeon-arguments nil "A list of strings to pass to Galeon as arguments." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (make-obsolete-variable 'browse-url-galeon-arguments nil "25.1") @@ -320,27 +332,23 @@ Defaults to the value of `browse-url-firefox-arguments' at the time "A list of strings to pass to Galeon when it starts up. Defaults to the value of `browse-url-galeon-arguments' at the time `browse-url' is loaded." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (make-obsolete-variable 'browse-url-galeon-startup-arguments nil "25.1") (defcustom browse-url-epiphany-program "epiphany" "The name by which to invoke Epiphany." - :type 'string - :group 'browse-url) + :type 'string) (defcustom browse-url-epiphany-arguments nil "A list of strings to pass to Epiphany as arguments." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (defcustom browse-url-epiphany-startup-arguments browse-url-epiphany-arguments "A list of strings to pass to Epiphany when it starts up. Defaults to the value of `browse-url-epiphany-arguments' at the time `browse-url' is loaded." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) ;; GNOME means of invoking either Mozilla or Netscape. (defvar browse-url-gnome-moz-program "gnome-moz-remote") @@ -350,8 +358,7 @@ Defaults to the value of `browse-url-epiphany-arguments' at the time (defcustom browse-url-gnome-moz-arguments '() "A list of strings passed to the GNOME mozilla viewer as arguments." :version "21.1" - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (make-obsolete-variable 'browse-url-gnome-moz-arguments nil "25.1") @@ -359,30 +366,26 @@ Defaults to the value of `browse-url-epiphany-arguments' at the time "Whether to open up new windows in a tab or a new window. If non-nil, then open the URL in a new tab rather than a new window if `browse-url-mozilla' is asked to open it in a new window." - :type 'boolean - :group 'browse-url) + :type 'boolean) (defcustom browse-url-firefox-new-window-is-tab nil "Whether to open up new windows in a tab or a new window. If non-nil, then open the URL in a new tab rather than a new window if `browse-url-firefox' is asked to open it in a new window." - :type 'boolean - :group 'browse-url) + :type 'boolean) (defcustom browse-url-conkeror-new-window-is-buffer nil "Whether to open up new windows in a buffer or a new window. If non-nil, then open the URL in a new buffer rather than a new window if `browse-url-conkeror' is asked to open it in a new window." :version "25.1" - :type 'boolean - :group 'browse-url) + :type 'boolean) (defcustom browse-url-galeon-new-window-is-tab nil "Whether to open up new windows in a tab or a new window. If non-nil, then open the URL in a new tab rather than a new window if `browse-url-galeon' is asked to open it in a new window." - :type 'boolean - :group 'browse-url) + :type 'boolean) (make-obsolete-variable 'browse-url-galeon-new-window-is-tab nil "25.1") @@ -390,16 +393,14 @@ If non-nil, then open the URL in a new tab rather than a new window if "Whether to open up new windows in a tab or a new window. If non-nil, then open the URL in a new tab rather than a new window if `browse-url-epiphany' is asked to open it in a new window." - :type 'boolean - :group 'browse-url) + :type 'boolean) (defcustom browse-url-netscape-new-window-is-tab nil "Whether to open up new windows in a tab or a new window. If non-nil, then open the URL in a new tab rather than a new window if `browse-url-netscape' is asked to open it in a new window." - :type 'boolean - :group 'browse-url) + :type 'boolean) (make-obsolete-variable 'browse-url-netscape-new-window-is-tab nil "25.1") @@ -407,42 +408,36 @@ window." "Non-nil means always open a new browser window with appropriate browsers. Passing an interactive argument to \\[browse-url], or specific browser commands reverses the effect of this variable." - :type 'boolean - :group 'browse-url) + :type 'boolean) (defcustom browse-url-mosaic-program "xmosaic" "The name by which to invoke Mosaic (or mMosaic)." :type 'string - :version "20.3" - :group 'browse-url) + :version "20.3") (make-obsolete-variable 'browse-url-mosaic-program nil "25.1") (defcustom browse-url-mosaic-arguments nil "A list of strings to pass to Mosaic as arguments." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (make-obsolete-variable 'browse-url-mosaic-arguments nil "25.1") (defcustom browse-url-mosaic-pidfile "~/.mosaicpid" "The name of the pidfile created by Mosaic." - :type 'string - :group 'browse-url) + :type 'string) (make-obsolete-variable 'browse-url-mosaic-pidfile nil "25.1") (defcustom browse-url-conkeror-program "conkeror" "The name by which to invoke Conkeror." :type 'string - :version "25.1" - :group 'browse-url) + :version "25.1") (defcustom browse-url-conkeror-arguments nil "A list of strings to pass to Conkeror as arguments." :version "25.1" - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (defcustom browse-url-filename-alist `(("^/\\(ftp@\\|anonymous@\\)?\\([^:/]+\\):/*" . "ftp://\\2/") @@ -473,26 +468,22 @@ address to an HTTP URL: :type '(repeat (cons :format "%v" (regexp :tag "Regexp") (string :tag "Replacement"))) - :version "25.1" - :group 'browse-url) + :version "25.1") (defcustom browse-url-save-file nil "If non-nil, save the buffer before displaying its file. Used by the `browse-url-of-file' command." - :type 'boolean - :group 'browse-url) + :type 'boolean) (defcustom browse-url-of-file-hook nil "Hook run after `browse-url-of-file' has asked a browser to load a file." - :type 'hook - :group 'browse-url) + :type 'hook) (defcustom browse-url-CCI-port 3003 "Port to access XMosaic via CCI. This can be any number between 1024 and 65535 but must correspond to the value set in the browser." - :type 'integer - :group 'browse-url) + :type 'integer) (make-obsolete-variable 'browse-url-CCI-port nil "25.1") @@ -500,8 +491,7 @@ the value set in the browser." "Host to access XMosaic via CCI. This should be the host name of the machine running XMosaic with CCI enabled. The port number should be set in `browse-url-CCI-port'." - :type 'string - :group 'browse-url) + :type 'string) (make-obsolete-variable 'browse-url-CCI-host nil "25.1") @@ -511,57 +501,48 @@ enabled. The port number should be set in `browse-url-CCI-port'." (defcustom browse-url-xterm-program "xterm" "The name of the terminal emulator used by `browse-url-text-xterm'. This might, for instance, be a separate color version of xterm." - :type 'string - :group 'browse-url) + :type 'string) (defcustom browse-url-xterm-args nil "A list of strings defining options for `browse-url-xterm-program'. These might set its size, for instance." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (defcustom browse-url-gnudoit-program "gnudoit" "The name of the `gnudoit' program used by `browse-url-w3-gnudoit'." - :type 'string - :group 'browse-url) + :type 'string) (defcustom browse-url-gnudoit-args '("-q") "A list of strings defining options for `browse-url-gnudoit-program'. These might set the port, for instance." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (defcustom browse-url-generic-program nil "The name of the browser program used by `browse-url-generic'." - :type '(choice string (const :tag "None" nil)) - :group 'browse-url) + :type '(choice string (const :tag "None" nil))) (defcustom browse-url-generic-args nil "A list of strings defining options for `browse-url-generic-program'." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (defcustom browse-url-temp-dir temporary-file-directory "The name of a directory for browse-url's temporary files. Such files are generated by functions like `browse-url-of-region'. You might want to set this to somewhere with restricted read permissions for privacy's sake." - :type 'string - :group 'browse-url) + :type 'string) (defcustom browse-url-netscape-version 3 "The version of Netscape you are using. This affects how URL reloading is done; the mechanism changed incompatibly at version 4." - :type 'number - :group 'browse-url) + :type 'number) (make-obsolete-variable 'browse-url-netscape-version nil "25.1") (defcustom browse-url-text-browser "lynx" "The name of the text browser to invoke." :type 'string - :group 'browse-url :version "23.1") (defcustom browse-url-text-emacs-args (and (not window-system) @@ -572,8 +553,7 @@ The default is none in a window system, otherwise `-show_cursor' to indicate the position of the current link in the absence of highlighting, assuming the normal default for showing the cursor." :type '(repeat (string :tag "Argument")) - :version "23.1" - :group 'browse-url) + :version "23.1") (defcustom browse-url-text-input-field 'avoid "Action on selecting an existing text browser buffer at an input field. @@ -586,36 +566,30 @@ down (this *won't* always work)." :type '(choice (const :tag "Move to try to avoid field" :value avoid) (const :tag "Disregard" :value nil) (const :tag "Warn, don't emit URL" :value warn)) - :version "23.1" - :group 'browse-url) + :version "23.1") (defcustom browse-url-text-input-attempts 10 "How many times to try to move down from a series of text browser input fields." :type 'integer - :version "23.1" - :group 'browse-url) + :version "23.1") (defcustom browse-url-text-input-delay 0.2 "Seconds to wait for a text browser between moves down from an input field." :type 'number - :version "23.1" - :group 'browse-url) + :version "23.1") (defcustom browse-url-kde-program "kfmclient" "The name by which to invoke the KDE web browser." :type 'string - :version "21.1" - :group 'browse-url) + :version "21.1") (defcustom browse-url-kde-args '("openURL") "A list of strings defining options for `browse-url-kde-program'." - :type '(repeat (string :tag "Argument")) - :group 'browse-url) + :type '(repeat (string :tag "Argument"))) (defcustom browse-url-elinks-wrapper '("xterm" "-e") "Wrapper command prepended to the Elinks command-line." - :type '(repeat (string :tag "Wrapper")) - :group 'browse-url) + :type '(repeat (string :tag "Wrapper"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; URL encoding @@ -713,8 +687,7 @@ Use variable `browse-url-filename-alist' to map filenames to URLs." (let ((coding (if (equal system-type 'windows-nt) ;; W32 pretends that file names are UTF-8 encoded. 'utf-8 - (and (default-value 'enable-multibyte-characters) - (or file-name-coding-system + (and (or file-name-coding-system default-file-name-coding-system))))) (if coding (setq file (encode-coding-string file coding)))) (setq file (browse-url-url-encode-chars file "[*\"()',=;?% ]")) @@ -1257,18 +1230,16 @@ used instead of `browse-url-new-window-flag'." (defvar url-handler-regexp) ;;;###autoload -(defun browse-url-emacs (url &optional _new-window) - "Ask Emacs to load URL into a buffer and show it in another window." +(defun browse-url-emacs (url &optional same-window) + "Ask Emacs to load URL into a buffer and show it in another window. +Optional argument SAME-WINDOW non-nil means show the URL in the +currently selected window instead." (interactive (browse-url-interactive-arg "URL: ")) (require 'url-handlers) (let ((file-name-handler-alist (cons (cons url-handler-regexp 'url-file-handler) file-name-handler-alist))) - ;; Ignore `new-window': with all other browsers the URL is always shown - ;; in another window than the current Emacs one since it's shown in - ;; another application's window. - ;; (if new-window (find-file-other-window url) (find-file url)) - (find-file-other-window url))) + (if same-window (find-file url) (find-file-other-window url)))) ;;;###autoload (defun browse-url-gnome-moz (url &optional new-window) @@ -1676,6 +1647,67 @@ from `browse-url-elinks-wrapper'." (error "Unrecognized exit-code %d of process `elinks'" exit-status)))) +;;; Adding buttons to a buffer to call `browse-url' when you hit them. + +(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) + map) + "The keymap used for browse-url buttons.") + +(defface browse-url-button + '((t :inherit link)) + "Face for browse-url buttons (i.e., links)." + :version "27.1") + +(defun browse-url-add-buttons () + "Add clickable buttons to the text following point in the current buffer. +Everything that matches `browse-url-button-regexp' will be made +clickable and will use `browse-url' to open the URLs in question." + (let ((inhibit-read-only t)) + (save-excursion + (while (re-search-forward browse-url-button-regexp nil t) + (add-text-properties (match-beginning 0) + (match-end 0) + `(help-echo "Open the URL under point" + keymap ,browse-url-button-map + face browse-url-button + button t + category browse-url + browse-url-data ,(match-string 0))))))) + +(defun browse-url-button-open (&optional external mouse-event) + "Follow the link under point using `browse-url'. +If EXTERNAL (the prefix if used interactively), open with the +external browser instead of the default one." + (interactive (list current-prefix-arg last-nonmenu-event)) + (mouse-set-point mouse-event) + (let ((url (get-text-property (point) 'browse-url-data))) + (unless url + (error "No URL under point")) + (if external + (funcall browse-url-secondary-browser-function url) + (browse-url url)))) + +(defun browse-url-button-open-url (url) + "Open URL using `browse-url'. +If `current-prefix-arg' is non-nil, use +`browse-url-secondary-browser-function' instead." + (if current-prefix-arg + (funcall browse-url-secondary-browser-function url) + (browse-url url))) + +(defun browse-url-button-copy () + "Copy the URL under point" + (interactive) + (let ((url (get-text-property (point) 'browse-url-data))) + (unless url + (error "No URL under point")) + (kill-new url) + (message "Copied %s" url))) + (provide 'browse-url) ;;; browse-url.el ends here diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 25e5d4dccc3..3820cd49f2b 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -41,9 +41,16 @@ (defvar dbus-message-type-method-return) (defvar dbus-message-type-error) (defvar dbus-message-type-signal) -(defvar dbus-debug) (defvar dbus-registered-objects-table) +;; The following symbols are defined in dbusbind.c. We need them also +;; when Emacs is compiled without D-Bus support. +(unless (boundp 'dbus-error) + (define-error 'dbus-error "D-Bus error")) + +(unless (boundp 'dbus-debug) + (defvar dbus-debug nil)) + ;; Pacify byte compiler. (eval-when-compile (require 'cl-lib)) diff --git a/lisp/net/dig.el b/lisp/net/dig.el index ad47982cc8e..ab199bd81c5 100644 --- a/lisp/net/dig.el +++ b/lisp/net/dig.el @@ -133,9 +133,7 @@ Buffer should contain output generated by `dig-invoke'." (define-derived-mode dig-mode special-mode "Dig" "Major mode for displaying dig output." (buffer-disable-undo) - (unless (featurep 'xemacs) - (set (make-local-variable 'font-lock-defaults) - '(dig-font-lock-keywords t))) + (setq-local font-lock-defaults '(dig-font-lock-keywords t)) (when (featurep 'font-lock) ;; FIXME: what is this for?? --Stef (font-lock-set-defaults)) diff --git a/lisp/net/dns.el b/lisp/net/dns.el index f6a804a6e86..9b0fd7235a2 100644 --- a/lisp/net/dns.el +++ b/lisp/net/dns.el @@ -106,7 +106,7 @@ updated. Set this variable to t to disable the check.") (defun dns-read-string-name (string buffer) (with-temp-buffer - (unless (featurep 'xemacs) (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (insert string) (goto-char (point-min)) (dns-read-name buffer))) @@ -117,7 +117,7 @@ updated. Set this variable to t to disable the check.") length) (while (not ended) (setq length (dns-read-bytes 1)) - (if (= 192 (logand length (lsh 3 6))) + (if (= 192 (logand length (ash 3 6))) (let ((offset (+ (* (logand 63 length) 256) (dns-read-bytes 1)))) (save-excursion @@ -140,21 +140,21 @@ updated. Set this variable to t to disable the check.") "Write a DNS packet according to SPEC. If TCP-P, the first two bytes of the package with be the length field." (with-temp-buffer - (unless (featurep 'xemacs) (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (dns-write-bytes (dns-get 'id spec) 2) (dns-write-bytes (logior - (lsh (if (dns-get 'response-p spec) 1 0) -7) - (lsh + (ash (if (dns-get 'response-p spec) 1 0) 7) + (ash (cond ((eq (dns-get 'opcode spec) 'query) 0) ((eq (dns-get 'opcode spec) 'inverse-query) 1) ((eq (dns-get 'opcode spec) 'status) 2) (t (error "No such opcode: %s" (dns-get 'opcode spec)))) - -3) - (lsh (if (dns-get 'authoritative-p spec) 1 0) -2) - (lsh (if (dns-get 'truncated-p spec) 1 0) -1) - (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0))) + 3) + (ash (if (dns-get 'authoritative-p spec) 1 0) 2) + (ash (if (dns-get 'truncated-p spec) 1 0) 1) + (ash (if (dns-get 'recursion-desired-p spec) 1 0) 0))) (dns-write-bytes (cond ((eq (dns-get 'response-code spec) 'no-error) 0) @@ -191,27 +191,27 @@ If TCP-P, the first two bytes of the package with be the length field." (defun dns-read (packet) (with-temp-buffer - (unless (featurep 'xemacs) (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (let ((spec nil) queries answers authorities additionals) (insert packet) (goto-char (point-min)) (push (list 'id (dns-read-bytes 2)) spec) (let ((byte (dns-read-bytes 1))) - (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t)) + (push (list 'response-p (if (zerop (logand byte (ash 1 7))) nil t)) spec) - (let ((opcode (logand byte (lsh 7 3)))) + (let ((opcode (logand byte (ash 7 3)))) (push (list 'opcode (cond ((eq opcode 0) 'query) ((eq opcode 1) 'inverse-query) ((eq opcode 2) 'status))) spec)) - (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2))) + (push (list 'authoritative-p (if (zerop (logand byte (ash 1 2))) nil t)) spec) - (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t)) + (push (list 'truncated-p (if (zerop (logand byte (ash 1 2))) nil t)) spec) (push (list 'recursion-desired-p - (if (zerop (logand byte (lsh 1 0))) nil t)) spec)) + (if (zerop (logand byte (ash 1 0))) nil t)) spec)) (let ((rc (logand (dns-read-bytes 1) 15))) (push (list 'response-code (cond @@ -268,7 +268,7 @@ If TCP-P, the first two bytes of the package with be the length field." (point (point))) (prog1 (with-temp-buffer - (unless (featurep 'xemacs) (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (insert string) (goto-char (point-min)) (cond @@ -356,26 +356,21 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." ;;; Interface functions. (defmacro dns-make-network-process (server) - (if (featurep 'xemacs) - `(let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (open-network-stream "dns" (current-buffer) - ,server "domain" 'udp)) - `(let ((server ,server) - (coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (if (fboundp 'make-network-process) - (make-network-process - :name "dns" - :coding 'binary - :buffer (current-buffer) - :host server - :service "domain" - :type 'datagram) - ;; Older versions of Emacs doesn't have - ;; `make-network-process', so we fall back on opening a TCP - ;; connection to the DNS server. - (open-network-stream "dns" (current-buffer) server "domain"))))) + `(let ((server ,server) + (coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (if (fboundp 'make-network-process) + (make-network-process + :name "dns" + :coding 'binary + :buffer (current-buffer) + :host server + :service "domain" + :type 'datagram) + ;; Older versions of Emacs doesn't have + ;; `make-network-process', so we fall back on opening a TCP + ;; connection to the DNS server. + (open-network-stream "dns" (current-buffer) server "domain")))) (defvar dns-cache (make-vector 4096 0)) @@ -409,7 +404,7 @@ If REVERSEP, look up an IP address." (if (not dns-servers) (message "No DNS server configuration found") (with-temp-buffer - (unless (featurep 'xemacs) (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (let ((process (condition-case () (dns-make-network-process (car dns-servers)) (error @@ -417,8 +412,6 @@ If REVERSEP, look up an IP address." "dns: Got an error while trying to talk to %s" (car dns-servers)) nil))) - (tcp-p (and (not (fboundp 'make-network-process)) - (not (featurep 'xemacs)))) (step 100) (times (* dns-timeout 1000)) (id (random 65000))) @@ -428,20 +421,16 @@ If REVERSEP, look up an IP address." (dns-write `((id ,id) (opcode query) (queries ((,name (type ,type)))) - (recursion-desired-p t)) - tcp-p)) + (recursion-desired-p t)))) (while (and (zerop (buffer-size)) (> times 0)) - (sit-for (/ step 1000.0)) - (accept-process-output process 0 step) + (let ((step-sec (/ step 1000.0))) + (sit-for step-sec) + (accept-process-output process step-sec)) (setq times (- times step))) (condition-case nil (delete-process process) (error nil)) - (when (and tcp-p - (>= (buffer-size) 2)) - (goto-char (point-min)) - (delete-region (point) (+ (point) 2))) (when (and (>= (buffer-size) 2) ;; We had a time-out. (> times 0)) diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el index 39b6ca9cdb9..59a4637eb80 100644 --- a/lisp/net/eudc-bob.el +++ b/lisp/net/eudc-bob.el @@ -25,8 +25,15 @@ ;;; Commentary: +;; eudc-bob.el presents binary entries in LDAP results in interactive +;; ways. For example, it will display JPEG binary data as an inline +;; image in the results buffer. See also +;; https://tools.ietf.org/html/rfc2798. + ;;; Usage: -;; See the corresponding info file + +;; The eudc-bob interactive functions are invoked when the user +;; interacts with an `eudc-query-form' results buffer. ;;; Code: @@ -148,40 +155,21 @@ display a button." "Toggle inline display of an image." (interactive) (when (eudc-bob-can-display-inline-images) - (cond ((featurep 'xemacs) - (let ((overlays (append (overlays-at (1- (point))) - (overlays-at (point)))) - overlay glyph) - (setq overlay (car overlays)) - (while (and overlay - (not (setq glyph (overlay-get overlay 'glyph)))) - (setq overlays (cdr overlays)) - (setq overlay (car overlays))) - (if overlay - (if (overlay-get overlay 'end-glyph) - (progn - (overlay-put overlay 'end-glyph nil) - (overlay-put overlay 'invisible nil)) - (overlay-put overlay 'end-glyph glyph) - (overlay-put overlay 'invisible t))))) - (t - (let* ((overlays (append (overlays-at (1- (point))) - (overlays-at (point)))) - image) - - ;; Search overlay with an image. - (while (and overlays (null image)) - (let ((prop (overlay-get (car overlays) 'eudc-image))) - (if (eq 'image (car-safe prop)) - (setq image prop) - (setq overlays (cdr overlays))))) - - ;; Toggle that overlay's image display. - (when overlays - (let ((overlay (car overlays))) - (overlay-put overlay 'display - (if (overlay-get overlay 'display) - nil image))))))))) + (let* ((overlays (append (overlays-at (1- (point))) + (overlays-at (point)))) + image) + ;; Search overlay with an image. + (while (and overlays (null image)) + (let ((prop (overlay-get (car overlays) 'eudc-image))) + (if (eq 'image (car-safe prop)) + (setq image prop) + (setq overlays (cdr overlays))))) + ;; Toggle that overlay's image display. + (when overlays + (let ((overlay (car overlays))) + (overlay-put overlay 'display + (if (overlay-get overlay 'display) + nil image))))))) (defun eudc-bob-display-audio (data) "Display a button for audio DATA." @@ -265,25 +253,19 @@ display a button." (interactive "@e") (run-hooks 'activate-menubar-hook) (eudc-jump-to-event event) - (if (featurep 'xemacs) - (progn - (run-hooks 'activate-popup-menu-hook) - (popup-menu (eudc-bob-menu))) - (let ((result (x-popup-menu t (eudc-bob-menu))) - command) - (if result - (progn - (setq command (lookup-key (eudc-bob-menu) - (apply 'vector result))) - (command-execute command)))))) + (let ((result (x-popup-menu t (eudc-bob-menu))) + command) + (if result + (progn + (setq command (lookup-key (eudc-bob-menu) + (apply 'vector result))) + (command-execute command))))) (setq 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 (if (featurep 'xemacs) - [button3] - [down-mouse-3]) 'eudc-bob-popup-menu) + (define-key map [down-mouse-3] 'eudc-bob-popup-menu) map)) (setq eudc-bob-image-keymap @@ -294,25 +276,19 @@ display a button." (setq eudc-bob-sound-keymap (let ((map (make-sparse-keymap))) (define-key map [return] 'eudc-bob-play-sound-at-point) - (define-key map (if (featurep 'xemacs) - [button2] - [down-mouse-2]) 'eudc-bob-play-sound-at-mouse) + (define-key map [down-mouse-2] 'eudc-bob-play-sound-at-mouse) map)) (setq eudc-bob-url-keymap (let ((map (make-sparse-keymap))) (define-key map [return] 'browse-url-at-point) - (define-key map (if (featurep 'xemacs) - [button2] - [down-mouse-2]) 'browse-url-at-mouse) + (define-key map [down-mouse-2] 'browse-url-at-mouse) map)) (setq eudc-bob-mail-keymap (let ((map (make-sparse-keymap))) (define-key map [return] 'goto-address-at-point) - (define-key map (if (featurep 'xemacs) - [button2] - [down-mouse-2]) 'goto-address-at-point) + (define-key map [down-mouse-2] 'goto-address-at-point) map)) (set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap) @@ -320,19 +296,18 @@ display a button." ;; If the first arguments can be nil here, then these 3 can be ;; defconsts once more. -(when (not (featurep 'xemacs)) - (easy-menu-define eudc-bob-generic-menu - eudc-bob-generic-keymap - "" - eudc-bob-generic-menu) - (easy-menu-define eudc-bob-image-menu - eudc-bob-image-keymap - "" - eudc-bob-image-menu) - (easy-menu-define eudc-bob-sound-menu - eudc-bob-sound-keymap - "" - eudc-bob-sound-menu)) +(easy-menu-define eudc-bob-generic-menu + eudc-bob-generic-keymap + "" + eudc-bob-generic-menu) +(easy-menu-define eudc-bob-image-menu + eudc-bob-image-keymap + "" + eudc-bob-image-menu) +(easy-menu-define eudc-bob-sound-menu + eudc-bob-sound-keymap + "" + eudc-bob-sound-menu) ;;;###autoload (defun eudc-display-generic-binary (data) diff --git a/lisp/net/eudc-hotlist.el b/lisp/net/eudc-hotlist.el index 05ea4903877..19788ba16cc 100644 --- a/lisp/net/eudc-hotlist.el +++ b/lisp/net/eudc-hotlist.el @@ -55,11 +55,6 @@ These are the special commands of this mode: t -- Transpose the server at point and the previous one q -- Commit the changes and quit. x -- Quit without committing the changes." - (when (featurep 'xemacs) - (setq mode-popup-menu eudc-hotlist-menu) - (when (featurep 'menubar) - (set-buffer-menubar current-menubar) - (add-submenu nil (cons "EUDC-Hotlist" (cdr (cdr eudc-hotlist-menu)))))) (setq buffer-read-only t)) ;;;###autoload @@ -179,10 +174,9 @@ These are the special commands of this mode: ["Save and Quit" eudc-hotlist-quit-edit t] ["Exit without Saving" kill-this-buffer t])) -(when (not (featurep 'xemacs)) - (easy-menu-define eudc-hotlist-emacs-menu +(easy-menu-define eudc-hotlist-emacs-menu eudc-hotlist-mode-map "" - eudc-hotlist-menu)) + eudc-hotlist-menu) ;;; eudc-hotlist.el ends here diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index bc550fbc113..3c9c01d0f96 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -1,4 +1,4 @@ -;;; eudc.el --- Emacs Unified Directory Client +;;; eudc.el --- Emacs Unified Directory Client -*- lexical-binding:t -*- ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. @@ -47,7 +47,7 @@ (require 'wid-edit) -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) (eval-and-compile (if (not (fboundp 'make-overlay)) @@ -68,6 +68,7 @@ (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) @@ -75,7 +76,6 @@ (define-key map "n" 'eudc-move-to-next-record) (define-key map "p" 'eudc-move-to-previous-record) map)) -(set-keymap-parent eudc-mode-map widget-keymap) (defvar mode-popup-menu) @@ -158,25 +158,6 @@ properties on the list." (setq plist (cdr (cdr plist)))) default)) -(if (not (fboundp 'split-string)) - (defun split-string (string &optional pattern) - "Return a list of substrings of STRING which are separated by PATTERN. -If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." - (or pattern - (setq pattern "[ \f\t\n\r\v]+")) - (let (parts (start 0)) - (when (string-match pattern string 0) - (if (> (match-beginning 0) 0) - (setq parts (cons (substring string 0 (match-beginning 0)) nil))) - (setq start (match-end 0)) - (while (and (string-match pattern string start) - (> (match-end 0) start)) - (setq parts (cons (substring string start (match-beginning 0)) parts) - start (match-end 0)))) - (nreverse (if (< start (length string)) - (cons (substring string start) parts) - parts))))) - (defun eudc-replace-in-string (str regexp newtext) "Replace all matches in STR for REGEXP with NEWTEXT. Value is the new string." @@ -314,7 +295,7 @@ accordingly. Otherwise it is set to its EUDC default binding" (defun eudc-update-local-variables () "Update all EUDC variables according to their local settings." (interactive) - (mapcar 'eudc-update-variable eudc-local-vars)) + (mapcar #'eudc-update-variable eudc-local-vars)) (eudc-default-set 'eudc-query-function nil) (eudc-default-set 'eudc-list-attributes-function nil) @@ -378,7 +359,7 @@ BEG and END delimit the text which is to be replaced." (let ((replacement)) (setq replacement (completing-read "Multiple matches found; choose one: " - (mapcar 'list choices))) + (mapcar #'list choices))) (delete-region beg end) (insert replacement))) @@ -415,7 +396,7 @@ underscore characters are replaced by spaces." (if match (cdr match) (capitalize - (mapconcat 'identity + (mapconcat #'identity (split-string (symbol-name attribute) "_") " "))))) @@ -432,7 +413,7 @@ if any, is called to print the value in cdr of FIELD." (progn (eval (list (cdr match) val)) (insert "\n")) - (mapcar + (mapc (function (lambda (val-elem) (indent-to col) @@ -598,9 +579,10 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'." (setq result (eudc-add-field-to-records (cons (car field) (mapconcat - 'identity + #'identity (cdr field) - "\n")) result))) + "\n")) + result))) ((eq 'duplicate method) (setq result (eudc-distribute-field-on-records field result))))))) @@ -613,12 +595,9 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'." (mapcar (function (lambda (rec) - (if (eval (cons 'and - (mapcar - (function - (lambda (attr) - (consp (assq attr rec)))) - attrs))) + (if (cl-every (lambda (attr) + (consp (assq attr rec))) + attrs) rec))) records))) @@ -632,25 +611,14 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'." (defun eudc-distribute-field-on-records (field records) "Duplicate each individual record in RECORDS according to value of FIELD. Each copy is added a new field containing one of the values of FIELD." - (let (result - (values (cdr field))) - ;; Uniquify values first - (while values - (setcdr values (delete (car values) (cdr values))) - (setq values (cdr values))) - (mapc - (function - (lambda (value) - (let ((result-list (copy-sequence records))) - (setq result-list (eudc-add-field-to-records - (cons (car field) value) - result-list)) - (setq result (append result-list result)) - ))) - (cdr field)) + (let (result) + (dolist (value (delete-dups (cdr field))) ;; Uniquify values first. + (setq result (nconc (eudc-add-field-to-records + (cons (car field) value) + records) + result))) result)) - (define-derived-mode eudc-mode special-mode "EUDC" "Major mode used in buffers displaying the results of directory queries. There is no sense in calling this command from a buffer other than @@ -662,9 +630,7 @@ These are the special commands of EUDC mode: n -- Move to next record. p -- Move to previous record. b -- Insert record at point into the BBDB database." - (if (not (featurep 'xemacs)) - (easy-menu-define eudc-emacs-menu eudc-mode-map "" (eudc-menu)) - (setq mode-popup-menu (eudc-menu)))) + (easy-menu-define eudc-emacs-menu eudc-mode-map "" (eudc-menu))) ;;}}} @@ -776,8 +742,8 @@ otherwise a list of symbols is returned." (setq query-alist (cdr query-alist))) query) (if eudc-protocol-has-default-query-attributes - (mapconcat 'identity words " ") - (list (cons 'name (mapconcat 'identity words " "))))))) + (mapconcat #'identity words " ") + (list (cons 'name (mapconcat #'identity words " "))))))) (defun eudc-extract-n-word-formats (format-list n) "Extract a list of N-long formats from FORMAT-LIST. @@ -836,7 +802,6 @@ see `eudc-inline-expansion-servers'" "[ \t]+")) query-formats response - response-string response-strings (eudc-former-server eudc-server) (eudc-former-protocol eudc-protocol) @@ -894,20 +859,18 @@ see `eudc-inline-expansion-servers'" (error "No match") ;; Process response through eudc-inline-expansion-format - (while response - (setq response-string - (apply 'format - (car eudc-inline-expansion-format) - (mapcar (function - (lambda (field) - (or (cdr (assq field (car response))) - ""))) - (eudc-translate-attribute-list - (cdr eudc-inline-expansion-format))))) - (if (> (length response-string) 0) - (setq response-strings - (cons response-string response-strings))) - (setq response (cdr response))) + (dolist (r response) + (let ((response-string + (apply #'format + (car eudc-inline-expansion-format) + (mapcar (function + (lambda (field) + (or (cdr (assq field r)) + ""))) + (eudc-translate-attribute-list + (cdr eudc-inline-expansion-format)))))) + (if (> (length response-string) 0) + (push response-string response-strings)))) (if (or (and replace (not eudc-expansion-overwrites-query)) @@ -923,7 +886,7 @@ see `eudc-inline-expansion-servers'" (eudc-select response-strings beg end)) ((eq eudc-multiple-match-handling-method 'all) (delete-region beg end) - (insert (mapconcat 'identity response-strings ", "))) + (insert (mapconcat #'identity response-strings ", "))) ((eq eudc-multiple-match-handling-method 'abort) (error "There is more than one match for the query"))))) (or (and (equal eudc-server eudc-former-server) @@ -943,10 +906,9 @@ queries the server for the existing fields and displays a corresponding form." prompts widget (width 0) - inhibit-read-only pt) (switch-to-buffer buffer) - (setq inhibit-read-only t) + (let ((inhibit-read-only t)) (erase-buffer) (kill-all-local-variables) (make-local-variable 'eudc-form-widget-list) @@ -960,11 +922,10 @@ queries the server for the existing fields and displays a corresponding form." (widget-insert "Protocol : " (symbol-name eudc-protocol) "\n") ;; Build the list of prompts (setq prompts (if eudc-use-raw-directory-names - (mapcar 'symbol-name (eudc-translate-attribute-list fields)) + (mapcar #'symbol-name (eudc-translate-attribute-list fields)) (mapcar (function (lambda (field) - (or (and (assq field eudc-user-attribute-names-alist) - (cdr (assq field eudc-user-attribute-names-alist))) + (or (cdr (assq field eudc-user-attribute-names-alist)) (capitalize (symbol-name field))))) fields))) ;; Loop over prompt strings to find the longest one @@ -1008,7 +969,7 @@ queries the server for the existing fields and displays a corresponding form." "Quit") (goto-char pt) (use-local-map widget-keymap) - (widget-setup)) + (widget-setup))) ) (defun eudc-bookmark-server (server protocol) @@ -1177,60 +1138,41 @@ queries the server for the existing fields and displays a corresponding form." eudc-tail-menu))) (defun eudc-install-menu () - (cond - ((and (featurep 'xemacs) (featurep 'menubar)) - (add-submenu '("Tools") (eudc-menu))) - ((not (featurep 'xemacs)) - (cond - ((fboundp 'easy-menu-create-menu) - (define-key - global-map - [menu-bar tools directory-search] - (cons "Directory Servers" - (easy-menu-create-menu "Directory Servers" (cdr (eudc-menu)))))) - ((fboundp 'easy-menu-add-item) - (let ((menu (eudc-menu))) - (easy-menu-add-item nil '("tools") (easy-menu-create-menu (car menu) - (cdr menu))))) - ((fboundp 'easy-menu-create-keymaps) - (easy-menu-define eudc-menu-map eudc-mode-map "Directory Client Menu" (eudc-menu)) - (define-key - global-map - [menu-bar tools eudc] - (cons "Directory Servers" - (easy-menu-create-keymaps "Directory Servers" - (cdr (eudc-menu)))))) - (t - (error "Unknown version of easymenu")))) - )) - + (define-key + global-map + [menu-bar tools directory-search] + (cons "Directory Servers" + (easy-menu-create-menu "Directory Servers" (cdr (eudc-menu)))))) ;;; Load time initializations : -;;; Load the options file +;; Load the options file (if (and (not noninteractive) (and (locate-library eudc-options-file) (progn (message "") t)) ; Remove mode line message (not (featurep 'eudc-options-file))) (load eudc-options-file)) -;;; Install the full menu +;; Install the full menu (unless (featurep 'infodock) (eudc-install-menu)) -;;; The following installs a short menu for EUDC at XEmacs startup. +;; The following installs a short menu for EUDC at Emacs startup. ;;;###autoload (defun eudc-load-eudc () "Load the Emacs Unified Directory Client. This does nothing except loading eudc by autoload side-effect." (interactive) + ;; FIXME: By convention, loading a file should "do nothing significant" + ;; since Emacs may occasionally load a file for "frivolous" reasons + ;; (e.g. to find a docstring), so having a function which just loads + ;; the file doesn't seem very useful. nil) ;;;###autoload -(cond - ((not (featurep 'xemacs)) +(progn (defvar eudc-tools-menu (let ((map (make-sparse-keymap "Directory Servers"))) (define-key map [phone] @@ -1255,34 +1197,6 @@ This does nothing except loading eudc by autoload side-effect." :help ,(purecopy "Load the Emacs Unified Directory Client"))) map)) (fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu))) - (t - (let ((menu '("Directory Servers" - ["Load Hotlist of Servers" eudc-load-eudc t] - ["New Server" eudc-set-server t] - ["---" nil nil] - ["Query with Form" eudc-query-form t] - ["Expand Inline Query" eudc-expand-inline t] - ["---" nil nil] - ["Get Email" eudc-get-email t] - ["Get Phone" eudc-get-phone t]))) - (if (not (featurep 'eudc-autoloads)) - (if (featurep 'xemacs) - (if (and (featurep 'menubar) - (not (featurep 'infodock))) - (add-submenu '("Tools") menu)) - (require 'easymenu) - (cond - ((fboundp 'easy-menu-add-item) - (easy-menu-add-item nil '("tools") - (easy-menu-create-menu (car menu) - (cdr menu)))) - ((fboundp 'easy-menu-create-keymaps) - (define-key - global-map - [menu-bar tools eudc] - (cons "Directory Servers" - (easy-menu-create-keymaps "Directory Servers" - (cdr menu))))))))))) ;;}}} diff --git a/lisp/net/eudcb-bbdb.el b/lisp/net/eudcb-bbdb.el index b99bea0fe8d..f91d0af858d 100644 --- a/lisp/net/eudcb-bbdb.el +++ b/lisp/net/eudcb-bbdb.el @@ -47,10 +47,13 @@ BBDB < 3 used `net'; BBDB >= 3 uses `mail'." ;; This just-in-time translation permits upgrading from BBDB 2 to ;; BBDB 3 without restarting Emacs. - (if (and (eq field-symbol 'net) - (eudc--using-bbdb-3-or-newer-p)) - 'mail - field-symbol)) + (cond ((and (eq field-symbol 'net) + (eudc--using-bbdb-3-or-newer-p)) + 'mail) + ((and (eq field-symbol 'company) + (eudc--using-bbdb-3-or-newer-p)) + 'organization) + (t field-symbol))) (defvar eudc-bbdb-attributes-translation-alist '((name . lastname) @@ -124,18 +127,31 @@ BBDB < 3 used `net'; BBDB >= 3 uses `mail'." (declare-function bbdb-record-addresses "ext:bbdb" t) ; via bbdb-defstruct (declare-function bbdb-records "ext:bbdb" (&optional dont-check-disk already-in-db-buffer)) +(declare-function bbdb-record-notes "ext:bbdb" t) ; via bbdb-defstruct + +;; External, BBDB >= 3. +(declare-function bbdb-phone-label "ext:bbdb" t) ; via bbdb-defstruct +(declare-function bbdb-record-phone "ext:bbdb" t) ; via bbdb-defstruct +(declare-function bbdb-record-address "ext:bbdb" t) ; via bbdb-defstruct +(declare-function bbdb-record-xfield "ext:bbdb" t) ; via bbdb-defstruct (defun eudc-bbdb-extract-phones (record) (require 'bbdb) (mapcar (function (lambda (phone) (if eudc-bbdb-use-locations-as-attribute-names - (cons (intern (bbdb-phone-location phone)) + (cons (intern (if (eudc--using-bbdb-3-or-newer-p) + (bbdb-phone-label phone) + (bbdb-phone-location phone))) (bbdb-phone-string phone)) (cons 'phones (format "%s: %s" - (bbdb-phone-location phone) + (if (eudc--using-bbdb-3-or-newer-p) + (bbdb-phone-label phone) + (bbdb-phone-location phone)) (bbdb-phone-string phone)))))) - (bbdb-record-phones record))) + (if (eudc--using-bbdb-3-or-newer-p) + (bbdb-record-phone record) + (bbdb-record-phones record)))) (defun eudc-bbdb-extract-addresses (record) (require 'bbdb) @@ -157,7 +173,9 @@ BBDB < 3 used `net'; BBDB >= 3 uses `mail'." (cons (intern (bbdb-address-location address)) val) (cons 'addresses (concat (bbdb-address-location address) "\n" val)))) - (bbdb-record-addresses record)))) + (if (eudc--using-bbdb-3-or-newer-p) + (bbdb-record-address record) + (bbdb-record-addresses record))))) (defun eudc-bbdb-format-record-as-result (record) "Format the BBDB RECORD as a EUDC query result record. @@ -176,7 +194,11 @@ The record is filtered according to `eudc-bbdb-current-return-attributes'" (setq val (eudc-bbdb-extract-phones record))) ((eq attr 'addresses) (setq val (eudc-bbdb-extract-addresses record))) - ((memq attr '(firstname lastname aka company net notes)) + ((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-" diff --git a/lisp/net/eudcb-mab.el b/lisp/net/eudcb-mab.el index dbee16e1e22..0202b173bb5 100644 --- a/lisp/net/eudcb-mab.el +++ b/lisp/net/eudcb-mab.el @@ -53,15 +53,15 @@ RETURN-ATTRS is a list of attributes to return, defaulting to (let ((fmt-string "%ln:%fn:%p:%e") (mab-buffer (get-buffer-create " *mab contacts*")) - (modified (nth 5 (file-attributes eudc-contacts-file))) + (modified (file-attribute-modification-time + (file-attributes eudc-contacts-file))) result) (with-current-buffer mab-buffer (make-local-variable 'eudc-buffer-time) (goto-char (point-min)) (when (or (eobp) (time-less-p eudc-buffer-time modified)) (erase-buffer) - (call-process (executable-find "contacts") nil t nil - "-H" "-l" "-f" fmt-string) + (call-process "contacts" nil t nil "-H" "-l" "-f" fmt-string) (setq eudc-buffer-time modified)) (goto-char (point-min)) (while (not (eobp)) diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 1cc4557ce1a..77e6cec9b04 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -29,7 +29,7 @@ (require 'shr) (require 'url) (require 'url-queue) -(require 'url-util) ; for url-get-url-at-point +(require 'thingatpt) (require 'mm-url) (require 'puny) (eval-when-compile (require 'subr-x)) ;; for string-trim @@ -64,17 +64,17 @@ ;;;###autoload (defcustom eww-suggest-uris '(eww-links-at-point - url-get-url-at-point + thing-at-point-url-at-point eww-current-url) "List of functions called to form the list of default URIs for `eww'. Each of the elements is a function returning either a string or a list of strings. The results will be joined into a single list with duplicate entries (if any) removed." - :version "25.1" + :version "27.1" :group 'eww :type 'hook :options '(eww-links-at-point - url-get-url-at-point + thing-at-point-url-at-point eww-current-url)) (defcustom eww-bookmarks-directory user-emacs-directory @@ -186,17 +186,17 @@ See also `eww-form-checkbox-selected-symbol'." :group 'eww) (defface eww-form-text - '((t (:background "#505050" - :foreground "white" - :box (:line-width 1)))) + '((t :background "#505050" + :foreground "white" + :box (:line-width 1))) "Face for eww text inputs." :version "24.4" :group 'eww) (defface eww-form-textarea - '((t (:background "#C0C0C0" - :foreground "black" - :box (:line-width 1)))) + '((t :background "#C0C0C0" + :foreground "black" + :box (:line-width 1))) "Face for eww textarea inputs." :version "24.4" :group 'eww) @@ -218,11 +218,21 @@ See also `eww-form-checkbox-selected-symbol'." (defvar eww-data nil) (defvar eww-history nil) (defvar eww-history-position 0) +(defvar eww-prompt-history nil) (defvar eww-local-regex "localhost" "When this regex is found in the URL, it's not a keyword but an address.") +(defvar eww-accept-content-types + "text/html, text/plain, text/sgml, text/css, application/xhtml+xml, */*;q=0.01" + "Value used for the HTTP 'Accept' header.") + (defvar eww-link-keymap + (let ((map (copy-keymap shr-map))) + (define-key map "\r" 'eww-follow-link) + map)) + +(defvar eww-image-link-keymap (let ((map (copy-keymap shr-image-map))) (define-key map "\r" 'eww-follow-link) map)) @@ -241,21 +251,29 @@ This list can be customized via `eww-suggest-uris'." (nreverse uris))) ;;;###autoload -(defun eww (url) +(defun eww (url &optional arg) "Fetch URL and render the page. If the input doesn't look like an URL or a domain name, the -word(s) will be searched for via `eww-search-prefix'." +word(s) will be searched for via `eww-search-prefix'. + +If called with a prefix ARG, use a new buffer instead of reusing +the default EWW buffer." (interactive (let* ((uris (eww-suggested-uris)) (prompt (concat "Enter URL or keywords" (if uris (format " (default %s)" (car uris)) "") ": "))) - (list (read-string prompt nil nil uris)))) + (list (read-string prompt nil 'eww-prompt-history uris) + (prefix-numeric-value current-prefix-arg)))) (setq url (eww--dwim-expand-url url)) (pop-to-buffer-same-window - (if (eq major-mode 'eww-mode) - (current-buffer) - (get-buffer-create "*eww*"))) + (cond + ((eq arg 4) + (generate-new-buffer "*eww*")) + ((eq major-mode 'eww-mode) + (current-buffer)) + (t + (get-buffer-create "*eww*")))) (eww-setup-buffer) ;; Check whether the domain only uses "Highly Restricted" Unicode ;; IDNA characters. If not, transform to punycode to indicate that @@ -263,16 +281,22 @@ word(s) will be searched for via `eww-search-prefix'." (let ((parsed (url-generic-parse-url url))) (when (url-host parsed) (unless (puny-highly-restrictive-domain-p (url-host parsed)) - (setf (url-host parsed) (puny-encode-domain (url-host parsed))) - (setq url (url-recreate-url parsed))))) + (setf (url-host parsed) (puny-encode-domain (url-host parsed))))) + ;; When the URL is on the form "http://a/../../../g", chop off all + ;; the leading "/.."s. + (when (url-filename parsed) + (while (string-match "\\`/[.][.]/" (url-filename parsed)) + (setf (url-filename parsed) (substring (url-filename parsed) 3)))) + (setq url (url-recreate-url parsed))) (plist-put eww-data :url url) (plist-put eww-data :title "") (eww-update-header-line-format) (let ((inhibit-read-only t)) (insert (format "Loading %s..." url)) (goto-char (point-min))) - (url-retrieve url 'eww-render - (list url nil (current-buffer)))) + (let ((url-mime-accept-string eww-accept-content-types)) + (url-retrieve url 'eww-render + (list url nil (current-buffer))))) (defun eww--dwim-expand-url (url) (setq url (string-trim url)) @@ -349,9 +373,6 @@ Currently this means either text/html or application/xhtml+xml." "application/xhtml+xml"))) (defun eww-render (status url &optional point buffer encode) - (let ((redirect (plist-get status :redirect))) - (when redirect - (setq url redirect))) (let* ((headers (eww-parse-headers)) (content-type (mail-header-parse-content-type @@ -364,12 +385,19 @@ Currently this means either text/html or application/xhtml+xml." (eww-detect-charset (eww-html-p (car content-type))) "utf-8")))) (data-buffer (current-buffer)) + (shr-target-id (url-target (url-generic-parse-url url))) last-coding-system-used) + (let ((redirect (plist-get status :redirect))) + (when redirect + (setq url redirect))) (with-current-buffer buffer ;; Save the https peer status. (plist-put eww-data :peer (plist-get status :peer)) ;; Make buffer listings more informative. - (setq list-buffers-directory url)) + (setq list-buffers-directory url) + ;; Let the URL library have a handle to the current URL for + ;; referer purposes. + (setq url-current-lastloc (url-generic-parse-url url))) (unwind-protect (progn (cond @@ -447,10 +475,10 @@ Currently this means either text/html or application/xhtml+xml." (condition-case nil (decode-coding-region (point) (point-max) encode) (coding-system-error nil)) - (save-excursion - ;; Remove CRLF before parsing. - (while (re-search-forward "\r$" nil t) - (replace-match "" t t))) + (save-excursion + ;; Remove CRLF and replace NUL with � before parsing. + (while (re-search-forward "\\(\r$\\)\\|\0" nil t) + (replace-match (if (match-beginning 1) "" "�") t t))) (libxml-parse-html-region (point) (point-max)))))) (source (and (null document) (buffer-substring (point) (point-max))))) @@ -460,7 +488,6 @@ Currently this means either text/html or application/xhtml+xml." (plist-put eww-data :dom document) (let ((inhibit-read-only t) (inhibit-modification-hooks t) - (shr-target-id (url-target (url-generic-parse-url url))) (shr-external-rendering-functions (append shr-external-rendering-functions @@ -547,7 +574,11 @@ Currently this means either text/html or application/xhtml+xml." (eww-handle-link dom) (let ((start (point))) (shr-tag-a dom) - (put-text-property start (point) 'keymap eww-link-keymap))) + (put-text-property start (point) + 'keymap + (if (mm-images-in-region-p start (point)) + eww-image-link-keymap + eww-link-keymap)))) (defun eww-update-header-line-format () (setq header-line-format @@ -731,7 +762,10 @@ the like." most-negative-fixnum) (or (dom-attr result :eww-readability-score) most-negative-fixnum)) - (setq result highest))) + ;; We set a lower bound to how long we accept that the + ;; readable portion of the page is going to be. + (when (> (length (split-string (dom-texts highest))) 100) + (setq result highest)))) result)) (defvar eww-mode-map @@ -923,8 +957,9 @@ just re-display the HTML already fetched." (error "No current HTML data") (eww-display-html 'utf-8 url (plist-get eww-data :dom) (point) (current-buffer))) - (url-retrieve url 'eww-render - (list url (point) (current-buffer) encode))))) + (let ((url-mime-accept-string eww-accept-content-types)) + (url-retrieve url 'eww-render + (list url (point) (current-buffer) encode)))))) ;; Form support. @@ -1236,14 +1271,8 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") :eww-form eww-form)) (options nil) (start (point)) - (max 0) - opelem) - (if (eq (dom-tag dom) 'optgroup) - (dolist (groupelem (dom-children dom)) - (unless (dom-attr groupelem 'disabled) - (setq opelem (append opelem (list groupelem))))) - (setq opelem (list dom))) - (dolist (elem opelem) + (max 0)) + (dolist (elem (dom-non-text-children dom)) (when (eq (dom-tag elem) 'option) (when (dom-attr elem 'selected) (nconc menu (list :value (dom-attr elem 'value)))) @@ -1472,13 +1501,17 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (defun eww-browse-with-external-browser (&optional url) "Browse the current URL with an external browser. -The browser to used is specified by the `shr-external-browser' variable." +The browser to used is specified by the +`browse-url-secondary-browser-function' variable." (interactive) - (funcall shr-external-browser (or url (plist-get eww-data :url)))) + (funcall browse-url-secondary-browser-function + (or url (plist-get eww-data :url)))) (defun eww-follow-link (&optional external mouse-event) "Browse the URL under point. -If EXTERNAL is single prefix, browse the URL using `shr-external-browser'. +If EXTERNAL is single prefix, browse the URL using +`browse-url-secondary-browser-function'. + If EXTERNAL is double prefix, browse in new buffer." (interactive (list current-prefix-arg last-nonmenu-event)) (mouse-set-point mouse-event) @@ -1489,12 +1522,14 @@ If EXTERNAL is double prefix, browse in new buffer." ((string-match "^mailto:" url) (browse-url-mail url)) ((and (consp external) (<= (car external) 4)) - (funcall shr-external-browser url)) + (funcall browse-url-secondary-browser-function url) + (shr--blink-link)) ;; This is a #target url in the same page as the current one. ((and (url-target (url-generic-parse-url url)) (eww-same-page-p url (plist-get eww-data :url))) (let ((dom (plist-get eww-data :dom))) (eww-save-history) + (plist-put eww-data :url url) (eww-display-html 'utf-8 url dom nil (current-buffer)))) (t (eww-browse-url url external))))) @@ -1515,10 +1550,12 @@ Differences in #targets are ignored." (kill-new (plist-get eww-data :url))) (defun eww-download () - "Download URL under point to `eww-download-directory'." + "Download URL to `eww-download-directory'. +Use link at point if there is one, else the current page's URL." (interactive) (access-file eww-download-directory "Download failed") - (let ((url (get-text-property (point) 'shr-url))) + (let ((url (or (get-text-property (point) 'shr-url) + (eww-current-url)))) (if (not url) (message "No URL under point") (url-retrieve url 'eww-download-callback (list url))))) @@ -1651,7 +1688,7 @@ If CHARSET is nil then use UTF-8." (defun eww-read-bookmarks () (let ((file (expand-file-name "eww-bookmarks" eww-bookmarks-directory))) (setq eww-bookmarks - (unless (zerop (or (nth 7 (file-attributes file)) 0)) + (unless (zerop (or (file-attribute-size (file-attributes file)) 0)) (with-temp-buffer (insert-file-contents file) (read (current-buffer))))))) @@ -1797,13 +1834,9 @@ If CHARSET is nil then use UTF-8." (defun eww-save-history () (plist-put eww-data :point (point)) (plist-put eww-data :text (buffer-string)) - (push eww-data eww-history) - (setq eww-data (list :title "")) - ;; Don't let the history grow infinitely. We store quite a lot of - ;; data per page. - (when-let* ((tail (and eww-history-limit - (nthcdr eww-history-limit eww-history)))) - (setcdr tail nil))) + (let ((history-delete-duplicates nil)) + (add-to-history 'eww-history eww-data eww-history-limit t)) + (setq eww-data (list :title ""))) (defvar eww-current-buffer) diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index 0dcffbb9b14..61480f35877 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -36,6 +36,10 @@ ;;; Code: (require 'cl-lib) +(require 'puny) + +(declare-function network-stream-certificate "network-stream" + (host service parameters)) (defgroup gnutls nil "Emacs interface to the GnuTLS library." @@ -69,9 +73,9 @@ If the value is a list, it should have the form ((HOST-REGEX FLAGS...) (HOST-REGEX FLAGS...) ...) where each HOST-REGEX is a regular expression to be matched -against the hostname, and FLAGS is either t or a list of -one or more verification flags. The supported flags and the -corresponding conditions to be tested are: +against the hostname, on a first-match basis, and FLAGS is either +t or a list of one or more verification flags. The supported +flags and the corresponding conditions to be tested are: :trustfiles -- certificate must be issued by a trusted authority. :hostname -- hostname must match presented certificate's host name. @@ -137,7 +141,7 @@ node `(emacs) Network Security'." (integer :tag "Number of bits" 512)) :group 'gnutls) -(defun open-gnutls-stream (name buffer host service &optional nowait) +(defun open-gnutls-stream (name buffer host service &optional parameters) "Open a SSL/TLS connection for a service to a host. Returns a subprocess-object to represent the connection. Input and output work as for subprocesses; `delete-process' closes it. @@ -148,12 +152,15 @@ BUFFER is the buffer (or `buffer-name') to associate with the process. a filter function to handle the output. BUFFER may be also nil, meaning that this process is not associated with any buffer -Third arg is name of the host to connect to, or its IP address. -Fourth arg SERVICE is name of the service desired, or an integer +Third arg HOST is the name of the host to connect to, or its IP address. +Fourth arg SERVICE is the name of the service desired, or an integer specifying a port number to connect to. -Fifth arg NOWAIT (which is optional) means that the socket should -be opened asynchronously. The connection process will be -returned to the caller before TLS negotiation has happened. +Fifth arg PARAMETERS is an optional list of keyword/value pairs. +Only :client-certificate and :nowait keywords are recognized, and +have the same meaning as for `open-network-stream'. +For historical reasons PARAMETERS can also be a symbol, which is +interpreted the same as passing a list containing :nowait and the +value of that symbol. Usage example: @@ -167,20 +174,34 @@ This is a very simple wrapper around `gnutls-negotiate'. See its documentation for the specific parameters you can use to open a GnuTLS connection, including specifying the credential type, trust and key files, and priority string." - (let ((process (open-network-stream - name buffer host service - :nowait nowait - :tls-parameters - (and nowait - (cons 'gnutls-x509pki - (gnutls-boot-parameters - :type 'gnutls-x509pki - :hostname host)))))) + (let* ((parameters + (cond ((symbolp parameters) + (list :nowait parameters)) + ((not (cl-evenp (length parameters))) + (error "Malformed keyword list")) + ((consp parameters) + parameters) + (t + (error "Unknown parameter type")))) + (cert (network-stream-certificate host service parameters)) + (keylist (and cert (list cert))) + (nowait (plist-get parameters :nowait)) + (process (open-network-stream + name buffer host service + :nowait nowait + :tls-parameters + (and nowait + (cons 'gnutls-x509pki + (gnutls-boot-parameters + :type 'gnutls-x509pki + :keylist keylist + :hostname (puny-encode-domain host))))))) (if nowait process (gnutls-negotiate :process process :type 'gnutls-x509pki - :hostname host)))) + :keylist keylist + :hostname (puny-encode-domain host))))) (define-error 'gnutls-error "GnuTLS error") @@ -303,13 +324,9 @@ defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT." t) ;; if a list, look for hostname matches ((listp gnutls-verify-error) - (apply 'append - (mapcar - (lambda (check) - (when (string-match (nth 0 check) - hostname) - (nth 1 check))) - gnutls-verify-error))) + (cadr (cl-find-if #'(lambda (x) + (string-match (car x) hostname)) + gnutls-verify-error))) ;; else it's nil (t nil)))) (min-prime-bits (or min-prime-bits gnutls-min-prime-bits))) diff --git a/lisp/net/goto-addr.el b/lisp/net/goto-addr.el index 45627d9b103..40a067e6251 100644 --- a/lisp/net/goto-addr.el +++ b/lisp/net/goto-addr.el @@ -59,19 +59,10 @@ ;;; Code: +(require 'seq) (require 'thingatpt) (autoload 'browse-url-url-at-point "browse-url") -;; XEmacs needs the following definitions. -(unless (fboundp 'overlays-in) - (require 'overlay)) -(unless (fboundp 'line-beginning-position) - (defalias 'line-beginning-position 'point-at-bol)) -(unless (fboundp 'line-end-position) - (defalias 'line-end-position 'point-at-eol)) -(unless (fboundp 'match-string-no-properties) - (defalias 'match-string-no-properties 'match-string)) - (defgroup goto-address nil "Click to browse URL or to send to e-mail address." :group 'mouse @@ -98,32 +89,40 @@ A value of t means there is no limit--fontify regardless of the size." (defvar goto-address-mail-regexp ;; Actually pretty much any char could appear in the username part. -stef - "[-a-zA-Z0-9=._+]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+" + "[-a-zA-Z0-9=._+]+@\\([-a-zA-Z0-9_]+\\.\\)+[a-zA-Z0-9]+" "A regular expression probably matching an e-mail address.") +(defvar goto-address-uri-schemes-ignored + ;; By default we exclude `mailto:' (email addresses are matched + ;; by `goto-address-mail-regexp') and also `data:', as it is not + ;; terribly useful to follow those URIs, and leaving them causes + ;; `use Data::Dumper;' to be fontified oddly in Perl files. + '("mailto:" "data:") + "List of URI schemes to exclude from `goto-address-uri-schemes'. + +Customisations to this variable made after goto-addr is loaded +will have no effect.") + +(defvar goto-address-uri-schemes + ;; We use `thing-at-point-uri-schemes', with a few exclusions, + ;; as listed in `goto-address-uri-schemes-ignored'. + (seq-reduce (lambda (accum elt) (delete elt accum)) + goto-address-uri-schemes-ignored + (copy-sequence thing-at-point-uri-schemes)) + "List of URI schemes matched by `goto-address-url-regexp'. + +Customisations to this variable made after goto-addr is loaded +will have no effect.") + (defvar goto-address-url-regexp - (concat - "\\<\\(" - (mapconcat 'identity - (delete "mailto:" - ;; Remove `data:', as it's not terribly useful to follow - ;; those. Leaving them causes `use Data::Dumper;' to be - ;; fontified oddly in Perl files. - (delete "data:" - (copy-sequence thing-at-point-uri-schemes))) - "\\|") - "\\)" - thing-at-point-url-path-regexp) - ;; (concat "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|" - ;; "telnet\\|wais\\):\\(//[-a-zA-Z0-9_.]+:" - ;; "[0-9]*\\)?[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*" - ;; "[-a-zA-Z0-9_=#$@~`%&*+|\\/]") + (concat "\\<" + (regexp-opt goto-address-uri-schemes t) + thing-at-point-url-path-regexp) "A regular expression probably matching a URL.") (defvar goto-address-highlight-keymap (let ((m (make-sparse-keymap))) - (define-key m (if (featurep 'xemacs) (kbd "<button2>") (kbd "<mouse-2>")) - 'goto-address-at-point) + (define-key m (kbd "<mouse-2>") '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.") @@ -221,10 +220,6 @@ and `goto-address-fontify-p'." ;; snarfed from browse-url.el ;;;###autoload -(define-obsolete-function-alias - 'goto-address-at-mouse 'goto-address-at-point "22.1") - -;;;###autoload (defun goto-address-at-point (&optional event) "Send to the e-mail address or load the URL at point. Send mail to address at point. See documentation for @@ -250,7 +245,7 @@ there, then load the URL at or before point." "Find e-mail address around or before point. Then search backwards to beginning of line for the start of an e-mail address. If no e-mail address found, return nil." - (re-search-backward "[^-_A-z0-9.@]" (line-beginning-position) 'lim) + (re-search-backward "[^-_A-Za-z0-9.@]" (line-beginning-position) 'lim) (if (or (looking-at goto-address-mail-regexp) ; already at start (and (re-search-forward goto-address-mail-regexp (line-end-position) 'lim) @@ -274,10 +269,7 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and ;;;###autoload (define-minor-mode goto-address-mode - "Minor mode to buttonize URLs and e-mail addresses in the current buffer. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "Minor mode to buttonize URLs and e-mail addresses in the current buffer." nil "" nil diff --git a/lisp/net/hmac-def.el b/lisp/net/hmac-def.el index c471f691dc3..44db0bbbb24 100644 --- a/lisp/net/hmac-def.el +++ b/lisp/net/hmac-def.el @@ -73,7 +73,7 @@ If BIT is non-nil, truncate output to specified bits." ,(if (and bit (< (/ bit 8) L)) `(substring key-xor-opad 0 ,(/ bit 8)) ;; return a copy of `key-xor-opad'. - `(concat key-xor-opad))) + '(concat key-xor-opad))) ;; cleanup. (fillarray key-xor-ipad 0) (fillarray key-xor-opad 0))))) diff --git a/lisp/net/imap.el b/lisp/net/imap.el index dedf5f794a4..9f43c57ffd3 100644 --- a/lisp/net/imap.el +++ b/lisp/net/imap.el @@ -1,4 +1,4 @@ -;;; imap.el --- imap library +;;; imap.el --- imap library -*- lexical-binding:t -*- ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. @@ -135,20 +135,16 @@ ;;; Code: -(eval-when-compile (require 'cl)) -(eval-and-compile - ;; For Emacs <22.2 and XEmacs. - (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r))) - (autoload 'sasl-find-mechanism "sasl") - (autoload 'digest-md5-parse-digest-challenge "digest-md5") - (autoload 'digest-md5-digest-response "digest-md5") - (autoload 'digest-md5-digest-uri "digest-md5") - (autoload 'digest-md5-challenge "digest-md5") - (autoload 'rfc2104-hash "rfc2104") - (autoload 'utf7-encode "utf7") - (autoload 'utf7-decode "utf7") - (autoload 'format-spec "format-spec") - (autoload 'format-spec-make "format-spec")) +(eval-when-compile (require 'cl-lib)) +(require 'format-spec) +(require 'utf7) +(require 'rfc2104) +;; Hmm... digest-md5 is not part of Emacs. +;; FIXME: Should/can we use sasl-digest.el instead? +(declare-function digest-md5-parse-digest-challenge "ext:digest-md5") +(declare-function digest-md5-digest-response "ext:digest-md5") +(declare-function digest-md5-digest-uri "ext:digest-md5") +(declare-function digest-md5-challenge "ext:digest-md5") ;; User variables. @@ -1700,18 +1696,6 @@ MAILBOX specifies a mailbox on the server in BUFFER." (concat "UID STORE " articles " +FLAGS" (if silent ".SILENT") " (" flags ")")))))) -;; Cf. http://thread.gmane.org/gmane.emacs.gnus.general/65317/focus=65343 -;; Signal an error if we'd get an integer overflow. -;; -;; FIXME: Identify relevant calls to `string-to-number' and replace them with -;; `imap-string-to-integer'. -(defun imap-string-to-integer (string &optional base) - (let ((number (string-to-number string base))) - (if (> number most-positive-fixnum) - (error - (format "String %s cannot be converted to a Lisp integer" number)) - number))) - (defun imap-fetch-safe (uids props &optional receive nouidfetch buffer) "Like `imap-fetch', but DTRT with Exchange 2007 bug. However, UIDS here is a cons, where the car is the canonical form @@ -1900,9 +1884,7 @@ on failure." (setq cmdstr nil) (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) (setq command nil) ;; abort command if no cont-req - (let ((process imap-process) - (stream imap-stream) - (eol imap-client-eol)) + (let ((process imap-process)) (with-current-buffer cmd (imap-log cmd) (process-send-region process (point-min) @@ -1936,18 +1918,14 @@ on failure." (unless (< len 10) (setq imap-have-messaged t) (message "imap read: %dk" len)) - (accept-process-output imap-process - (truncate imap-read-timeout) - (truncate (* (- imap-read-timeout - (truncate imap-read-timeout)) - 1000))))) + (accept-process-output imap-process imap-read-timeout))) ;; A process can die _before_ we have processed everything it ;; has to say. Moreover, this can happen in between the call to ;; accept-process-output and the call to process-status in an ;; iteration of the loop above. (when (and (null imap-continuation) (< imap-reached-tag tag)) - (accept-process-output imap-process 0 0)) + (accept-process-output imap-process 0)) (when imap-have-messaged (message "")) (and (memq (process-status imap-process) '(open run)) @@ -1956,7 +1934,7 @@ on failure." 'INCOMPLETE 'OK)))))) -(defun imap-sentinel (process string) +(defun imap-sentinel (process _string) (delete-process process)) (defun imap-find-next-line () @@ -2145,7 +2123,7 @@ Return nil if no complete line has arrived." (imap-forward) (nreverse addresses))) ;; With assert, the code might not be eval'd. - ;; (assert (imap-parse-nil) t "In imap-parse-address-list") + ;; (cl-assert (imap-parse-nil) t "In imap-parse-address-list") (imap-parse-nil))) ;; mailbox = "INBOX" / astring @@ -2218,72 +2196,72 @@ Return nil if no complete line has arrived." (defun imap-parse-response () "Parse an IMAP command response." (let (token) - (case (setq token (read (current-buffer))) - (+ (setq imap-continuation - (or (buffer-substring (min (point-max) (1+ (point))) - (point-max)) - t))) - (* (case (prog1 (setq token (read (current-buffer))) - (imap-forward)) - (OK (imap-parse-resp-text)) - (NO (imap-parse-resp-text)) - (BAD (imap-parse-resp-text)) - (BYE (imap-parse-resp-text)) - (FLAGS (imap-mailbox-put 'flags (imap-parse-flag-list))) - (LIST (imap-parse-data-list 'list)) - (LSUB (imap-parse-data-list 'lsub)) - (SEARCH (imap-mailbox-put - 'search - (read (concat "(" (buffer-substring (point) (point-max)) ")")))) - (STATUS (imap-parse-status)) - (CAPABILITY (setq imap-capability + (pcase (setq token (read (current-buffer))) + ('+ (setq imap-continuation + (or (buffer-substring (min (point-max) (1+ (point))) + (point-max)) + t))) + ('* (pcase (prog1 (setq token (read (current-buffer))) + (imap-forward)) + ('OK (imap-parse-resp-text)) + ('NO (imap-parse-resp-text)) + ('BAD (imap-parse-resp-text)) + ('BYE (imap-parse-resp-text)) + ('FLAGS (imap-mailbox-put 'flags (imap-parse-flag-list))) + ('LIST (imap-parse-data-list 'list)) + ('LSUB (imap-parse-data-list 'lsub)) + ('SEARCH (imap-mailbox-put + 'search + (read (concat "(" (buffer-substring (point) (point-max)) ")")))) + ('STATUS (imap-parse-status)) + ('CAPABILITY (setq imap-capability (read (concat "(" (upcase (buffer-substring (point) (point-max))) ")")))) - (ID (setq imap-id (read (buffer-substring (point) - (point-max))))) - (ACL (imap-parse-acl)) - (t (case (prog1 (read (current-buffer)) - (imap-forward)) - (EXISTS (imap-mailbox-put 'exists token)) - (RECENT (imap-mailbox-put 'recent token)) - (EXPUNGE t) - (FETCH (imap-parse-fetch token)) - (t (message "Garbage: %s" (buffer-string))))))) - (t (let (status) + ('ID (setq imap-id (read (buffer-substring (point) + (point-max))))) + ('ACL (imap-parse-acl)) + (_ (pcase (prog1 (read (current-buffer)) + (imap-forward)) + ('EXISTS (imap-mailbox-put 'exists token)) + ('RECENT (imap-mailbox-put 'recent token)) + ('EXPUNGE t) + ('FETCH (imap-parse-fetch)) + (_ (message "Garbage: %s" (buffer-string))))))) + (_ (let (status) (if (not (integerp token)) (message "Garbage: %s" (buffer-string)) - (case (prog1 (setq status (read (current-buffer))) - (imap-forward)) - (OK (progn - (setq imap-reached-tag (max imap-reached-tag token)) - (imap-parse-resp-text))) - (NO (progn - (setq imap-reached-tag (max imap-reached-tag token)) - (save-excursion - (imap-parse-resp-text)) - (let (code text) - (when (eq (char-after) ?\[) - (setq code (buffer-substring (point) - (search-forward "]"))) - (imap-forward)) - (setq text (buffer-substring (point) (point-max))) - (push (list token status code text) - imap-failed-tags)))) - (BAD (progn - (setq imap-reached-tag (max imap-reached-tag token)) - (save-excursion - (imap-parse-resp-text)) - (let (code text) - (when (eq (char-after) ?\[) - (setq code (buffer-substring (point) - (search-forward "]"))) - (imap-forward)) - (setq text (buffer-substring (point) (point-max))) - (push (list token status code text) imap-failed-tags) - (error "Internal error, tag %s status %s code %s text %s" - token status code text)))) - (t (message "Garbage: %s" (buffer-string)))) + (pcase (prog1 (setq status (read (current-buffer))) + (imap-forward)) + ('OK (progn + (setq imap-reached-tag (max imap-reached-tag token)) + (imap-parse-resp-text))) + ('NO (progn + (setq imap-reached-tag (max imap-reached-tag token)) + (save-excursion + (imap-parse-resp-text)) + (let (code text) + (when (eq (char-after) ?\[) + (setq code (buffer-substring (point) + (search-forward "]"))) + (imap-forward)) + (setq text (buffer-substring (point) (point-max))) + (push (list token status code text) + imap-failed-tags)))) + ('BAD (progn + (setq imap-reached-tag (max imap-reached-tag token)) + (save-excursion + (imap-parse-resp-text)) + (let (code text) + (when (eq (char-after) ?\[) + (setq code (buffer-substring (point) + (search-forward "]"))) + (imap-forward)) + (setq text (buffer-substring (point) (point-max))) + (push (list token status code text) imap-failed-tags) + (error "Internal error, tag %s status %s code %s text %s" + token status code text)))) + (_ (message "Garbage: %s" (buffer-string)))) (when (assq token imap-callbacks) (funcall (cdr (assq token imap-callbacks)) token status) (setq imap-callbacks @@ -2459,7 +2437,7 @@ Return nil if no complete line has arrived." (search-forward "]" nil t)) section))) -(defun imap-parse-fetch (response) +(defun imap-parse-fetch () (when (eq (char-after) ?\() (let (uid flags envelope internaldate rfc822 rfc822header rfc822text rfc822size body bodydetail bodystructure flags-empty) @@ -2593,7 +2571,7 @@ Return nil if no complete line has arrived." (defun imap-parse-flag-list () (let (flag-list start) - (assert (eq (char-after) ?\() nil "In imap-parse-flag-list 1") + (cl-assert (eq (char-after) ?\() nil "In imap-parse-flag-list 1") (while (and (not (eq (char-after) ?\))) (setq start (progn (imap-forward) @@ -2602,7 +2580,7 @@ Return nil if no complete line has arrived." (point))) (> (skip-chars-forward "^ )" (point-at-eol)) 0)) (push (buffer-substring start (point)) flag-list)) - (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list 2") + (cl-assert (eq (char-after) ?\)) nil "In imap-parse-flag-list 2") (imap-forward) (nreverse flag-list))) @@ -2687,7 +2665,7 @@ Return nil if no complete line has arrived." (while (eq (char-after) ?\ ) (imap-forward) (push (imap-parse-body-extension) b-e)) - (assert (eq (char-after) ?\)) nil "In imap-parse-body-extension") + (cl-assert (eq (char-after) ?\)) nil "In imap-parse-body-extension") (imap-forward) (nreverse b-e)) (or (imap-parse-number) @@ -2716,7 +2694,7 @@ Return nil if no complete line has arrived." (push (imap-parse-string-list) dsp) (imap-forward)) ;; With assert, the code might not be eval'd. - ;; (assert (imap-parse-nil) t "In imap-parse-body-ext") + ;; (cl-assert (imap-parse-nil) t "In imap-parse-body-ext") (imap-parse-nil)) (push (nreverse dsp) ext)) (when (eq (char-after) ?\ ) ;; body-fld-lang @@ -2813,7 +2791,7 @@ Return nil if no complete line has arrived." (push (and (imap-parse-nil) nil) body)) (setq body (append (imap-parse-body-ext) body))) ;; body-ext-... - (assert (eq (char-after) ?\)) nil "In imap-parse-body") + (cl-assert (eq (char-after) ?\)) nil "In imap-parse-body") (imap-forward) (nreverse body)) @@ -2879,7 +2857,7 @@ Return nil if no complete line has arrived." (push (imap-parse-nstring) body) ;; body-fld-md5 (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part.. - (assert (eq (char-after) ?\)) nil "In imap-parse-body 2") + (cl-assert (eq (char-after) ?\)) nil "In imap-parse-body 2") (imap-forward) (nreverse body))))) diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el index 6e242d77d41..75fc7d62211 100644 --- a/lisp/net/ldap.el +++ b/lisp/net/ldap.el @@ -646,13 +646,9 @@ an alist of attribute/value pairs." (not (equal "" sizelimit))) (setq arglist (nconc arglist (list (format "-z%s" sizelimit))))) (if passwd - ;; Work around Bug#33154, see also Bug#33050. Leaving - ;; process-connection-type at its default (typically t) - ;; would probably be fine too, however this is the minimal - ;; change on the release branch that fixes ldap.el on Darwin - ;; and leaves other operating systems unchanged. - (let* ((process-connection-type (eq system-type 'darwin)) - (proc-args (append arglist ldap-ldapsearch-args + ;; Leave process-connection-type at its default value. See + ;; discussion in Bug#33050. + (let* ((proc-args (append arglist ldap-ldapsearch-args filter)) (proc (apply #'start-process "ldapsearch" buf ldap-ldapsearch-prog diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el index 78400e1dbba..eb4312ef3b5 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -36,6 +36,14 @@ :version "21.1" :group 'mime) +(defcustom mailcap-prefer-mailcap-viewers t + "If non-nil, prefer viewers specified in ~/.mailcap. +If nil, the most specific viewer will be chosen, even if there is +a general override in ~/.mailcap. For instance, if /etc/mailcap +has an entry for \"image/gif\", that one will be chosen even if +you have an entry for \"image/*\" in your ~/.mailcap file." + :type 'boolean) + (defvar mailcap-parse-args-syntax-table (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) (modify-syntax-entry ?' "\"" table) @@ -419,20 +427,32 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus ((memq system-type mailcap-poor-system-types) (setq path '("~/.mailcap" "~/mail.cap" "~/etc/mail.cap"))) (t (setq path - ;; This is per RFC 1524, specifically - ;; with /usr before /usr/local. - '("~/.mailcap" "/etc/mailcap" "/usr/etc/mailcap" - "/usr/local/etc/mailcap")))) - (dolist (fname (reverse - (if (stringp path) - (split-string path path-separator t) - path))) - (when (and (file-readable-p fname) (file-regular-p fname)) - (mailcap-parse-mailcap fname))) + ;; This is per RFC 1524, specifically with /usr before + ;; /usr/local. + '("~/.mailcap" + ("/etc/mailcap" 'after) + ("/usr/etc/mailcap" 'after) + ("/usr/local/etc/mailcap" 'after))))) + ;; We read the entries from ~/.mailcap before the built-in values, + ;; but place the rest of then afterwards as fallback values. + (dolist (spec (reverse + (if (stringp path) + (split-string path path-separator t) + path))) + (let ((afterp (and (consp spec) + (cadr spec))) + (file-name (if (stringp spec) + spec + (car spec)))) + (when (and (file-readable-p file-name) + (file-regular-p file-name)) + (mailcap-parse-mailcap file-name afterp)))) (setq mailcap-parsed-p t))) -(defun mailcap-parse-mailcap (fname) - "Parse out the mailcap file specified by FNAME." +(defun mailcap-parse-mailcap (fname &optional after) + "Parse out the mailcap file specified by FNAME. +If AFTER, place the entries from the file after the ones that are +already there." (let (major ; The major mime type (image/audio/etc) minor ; The minor mime type (gif, basic, etc) save-pos ; Misc saved positions used in parsing @@ -502,7 +522,7 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus "*" minor)))) (mailcap-parse-mailcap-extras save-pos (point)))) (mailcap-mailcap-entry-passes-test info) - (mailcap-add-mailcap-entry major minor info)) + (mailcap-add-mailcap-entry major minor info after)) (beginning-of-line))))) (defun mailcap-parse-mailcap-extras (st nd) @@ -685,7 +705,7 @@ to supply to the test." (push (list otest result) mailcap-viewer-test-cache) result)))) -(defun mailcap-add-mailcap-entry (major minor info) +(defun mailcap-add-mailcap-entry (major minor info &optional after) (let ((old-major (assoc major mailcap-mime-data))) (if (null old-major) ; New major area (push (cons major (list (cons minor info))) mailcap-mime-data) @@ -693,15 +713,23 @@ to supply to the test." (cond ((or (null cur-minor) ; New minor area, or (assq 'test info)) ; Has a test, insert at beginning - (setcdr old-major (cons (cons minor info) (cdr old-major)))) + (setcdr old-major + (if after ; Or after, if specified. + (nconc (cdr old-major) + (list (cons minor info))) + (cons (cons minor info) (cdr old-major))))) ((and (not (assq 'test info)) ; No test info, replace completely (not (assq 'test cur-minor)) (equal (assq 'viewer info) ; Keep alternative viewer (assq 'viewer cur-minor))) - (setcdr cur-minor info)) + (unless after + (setcdr cur-minor info))) (t - (setcdr old-major (cons (cons minor info) (cdr old-major)))))) - ))) + (setcdr old-major + (if after + (nconc (cdr old-major) (list (cons minor info))) + (setcdr old-major + (cons (cons minor info) (cdr old-major))))))))))) (defun mailcap-add (type viewer &optional test) "Add VIEWER as a handler for TYPE. @@ -784,18 +812,23 @@ If NO-DECODE is non-nil, don't decode STRING." (setq passed (list viewer)) ;; None found, so heuristically select some applicable viewer ;; from `mailcap-mime-data'. + (mailcap-parse-mailcaps) (setq major (split-string (car ctl) "/")) (setq minor (cadr major) major (car major)) (when (setq major-info (cdr (assoc major mailcap-mime-data))) (when (setq viewers (mailcap-possible-viewers major-info minor)) - (setq info (mapcar (lambda (a) (cons (symbol-name (car a)) - (cdr a))) + (setq info (mapcar (lambda (a) + (cons (symbol-name (car a)) (cdr a))) (cdr ctl))) (dolist (entry viewers) (when (mailcap-viewer-passes-test entry info) (push entry passed))) - (setq passed (sort passed 'mailcap-viewer-lessp)) + ;; The data is in "logical" order; entries from ~/.mailcap + ;; are first, so we don't need to do any sorting if the + ;; user wants ~/.mailcap to be preferred. + (unless mailcap-prefer-mailcap-viewers + (setq passed (sort passed 'mailcap-viewer-lessp))) (setq viewer (car passed)))) (when (and (stringp (cdr (assq 'viewer viewer))) passed) @@ -1006,6 +1039,14 @@ If FORCE, re-parse even if already parsed." (setq extn (concat "." extn))) (cdr (assoc (downcase extn) mailcap-mime-extensions))) +(defun mailcap-file-name-to-mime-type (file-name) + "Return the MIME content type based on the FILE-NAME's extension. +For instance, \"foo.png\" will result in \"image/png\"." + (mailcap-extension-to-mime + (if (string-match "\\(\\.[^.]+\\)\\'" file-name) + (match-string 1 file-name) + ""))) + (defun mailcap-mime-types () "Return a list of MIME media types." (mailcap-parse-mimetypes) diff --git a/lisp/net/mairix.el b/lisp/net/mairix.el index 07415667e1b..0c699c976ce 100644 --- a/lisp/net/mairix.el +++ b/lisp/net/mairix.el @@ -266,9 +266,7 @@ Currently there are `threads' and `flags'.") ;;; Gnus -;; For gnus-buffer-exists-p, although it seems that could be replaced by: -;; (and buffer (get-buffer buffer)) -(eval-when-compile (require 'gnus-util)) +(eval-when-compile (require 'gnus-util)) ; For `gnus-buffer-live-p'. (defvar gnus-article-buffer) (declare-function gnus-group-read-ephemeral-group "gnus-group" (group method &optional activate quit-config @@ -296,7 +294,7 @@ Currently there are `threads' and `flags'.") (unless (and (fboundp 'gnus-alive-p) (gnus-alive-p)) (error "Gnus is not running")) - (unless (gnus-buffer-exists-p gnus-article-buffer) + (unless (gnus-buffer-live-p gnus-article-buffer) (error "No article buffer available")) (with-current-buffer gnus-article-buffer ;; gnus-art requires gnus-sum and message. diff --git a/lisp/net/net-utils.el b/lisp/net/net-utils.el index fc39b91529a..dcc7e01b6b4 100644 --- a/lisp/net/net-utils.el +++ b/lisp/net/net-utils.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. -;; Author: Peter Breton <pbreton@cs.umb.edu> +;; Author: Peter Breton <pbreton@cs.umb.edu> ;; Created: Sun Mar 16 1997 ;; Keywords: network comm @@ -86,8 +86,6 @@ These options can be used to limit how many ICMP packets are emitted." :group 'net-utils :type '(repeat string)) -(define-obsolete-variable-alias 'ipconfig-program 'ifconfig-program "22.2") - (defcustom ifconfig-program (cond ((eq system-type 'windows-nt) "ipconfig") ((executable-find "ifconfig") "ifconfig") @@ -99,9 +97,6 @@ These options can be used to limit how many ICMP packets are emitted." :group 'net-utils :type 'string) -(define-obsolete-variable-alias 'ipconfig-program-options - 'ifconfig-program-options "22.2") - (defcustom ifconfig-program-options (cond ((string-match "ipconfig\\'" ifconfig-program) '("/all")) ((string-match "ifconfig\\'" ifconfig-program) '("-a")) diff --git a/lisp/net/netrc.el b/lisp/net/netrc.el index e7309850266..93152f4f2c4 100644 --- a/lisp/net/netrc.el +++ b/lisp/net/netrc.el @@ -63,12 +63,14 @@ "port")) alist elem result pair) (if (and netrc-cache - (equal (car netrc-cache) (nth 5 (file-attributes file)))) + (equal (car netrc-cache) (file-attribute-modification-time + (file-attributes file)))) (insert (base64-decode-string (rot13-string (cdr netrc-cache)))) (insert-file-contents file) (when (string-match "\\.gpg\\'" file) ;; Store the contents of the file heavily encrypted in memory. - (setq netrc-cache (cons (nth 5 (file-attributes file)) + (setq netrc-cache (cons (file-attribute-modification-time + (file-attributes file)) (rot13-string (base64-encode-string (buffer-string))))))) diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index 1d247812d9c..2b3292b71ba 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -42,14 +42,21 @@ ;;; Code: -(require 'tls) -(require 'starttls) (require 'auth-source) (require 'nsm) (require 'puny) +(declare-function starttls-available-p "starttls" ()) +(declare-function starttls-negotiate "starttls" (process)) +(declare-function starttls-open-stream "starttls" (name buffer host port)) + (autoload 'gnutls-negotiate "gnutls") (autoload 'open-gnutls-stream "gnutls") +(defvar starttls-extra-arguments) +(defvar starttls-extra-args) +(defvar starttls-use-gnutls) +(defvar starttls-gnutls-program) +(defvar starttls-program) ;;;###autoload (defun open-network-stream (name buffer host service &rest parameters) @@ -190,7 +197,7 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (car result)))))) (defun network-stream-certificate (host service parameters) - (let ((spec (plist-get :client-certificate parameters))) + (let ((spec (plist-get parameters :client-certificate))) (cond ((listp spec) ;; Either nil or a list with a key/certificate pair. @@ -255,7 +262,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (or (gnutls-available-p) (and (or require-tls (plist-get parameters :use-starttls-if-possible)) - (starttls-available-p)))) + (require 'starttls) + (starttls-available-p)))) (not (eq (plist-get parameters :type) 'plain))) ;; If using external STARTTLS, drop this connection and start ;; anew with `starttls-open-stream'. @@ -295,7 +303,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (if (gnutls-available-p) (let ((cert (network-stream-certificate host service parameters))) (condition-case nil - (gnutls-negotiate :process stream :hostname host + (gnutls-negotiate :process stream + :hostname (puny-encode-domain host) :keylist (and cert (list cert))) ;; If we get a gnutls-specific error (for instance if ;; the certificate the server gives us is completely @@ -335,7 +344,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." ;; See `starttls-available-p'. If this predicate ;; changes to allow running under Windows, the error ;; message below should be amended. - (if (memq system-type '(windows-nt ms-dos)) + (if (or (memq system-type '(windows-nt ms-dos)) + (not (featurep 'starttls))) (concat "Emacs does not support TLS") (concat "Emacs does not support TLS, and no external `" (if starttls-use-gnutls @@ -366,19 +376,22 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (goto-char start) (while (and (memq (process-status stream) '(open run)) (not (re-search-forward end-of-command nil t))) - (accept-process-output stream 0 50) + (accept-process-output stream 0.05) (goto-char start)) ;; Return the data we got back, or nil if the process died. (unless (= start (point)) (buffer-substring start (point))))))) +(declare-function open-tls-stream "tls" (name buffer host port)) + (defun network-stream-open-tls (name buffer host service parameters) (with-current-buffer buffer (let* ((start (point-max)) (stream (if (gnutls-available-p) (open-gnutls-stream name buffer host service - (plist-get parameters :nowait)) + parameters) + (require 'tls) (open-tls-stream name buffer host service))) (eoc (plist-get parameters :end-of-command))) (if (plist-get parameters :nowait) @@ -405,6 +418,9 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (network-stream-command stream capability-command eo-capa) 'tls))))))) +(declare-function format-spec "format-spec" (format spec)) +(declare-function format-spec-make "format-spec" (&rest pairs)) + (defun network-stream-open-shell (name buffer host service parameters) (require 'format-spec) (let* ((capability-command (plist-get parameters :capability-command)) diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index 96503bae18b..e356a0ece55 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -1,4 +1,4 @@ -;;; newst-backend.el --- Retrieval backend for newsticker. +;;; newst-backend.el --- Retrieval backend for newsticker -*- lexical-binding:t -*- ;; Copyright (C) 2003-2019 Free Software Foundation, Inc. @@ -170,7 +170,7 @@ These were mostly extracted from the Radio Community Server at http://subhonker6.userland.com/rcsPublic/rssHotlist. You may add other entries in `newsticker-url-list'." - :type `(set ,@(mapcar `newsticker--splicer + :type `(set ,@(mapcar #'newsticker--splicer newsticker--raw-url-list-defaults)) :set 'newsticker--set-customvar-retrieval :group 'newsticker-retrieval) @@ -435,40 +435,6 @@ buffers *newsticker-wget-<feed>* will not be closed." :group 'newsticker-miscellaneous) ;; ====================================================================== -;;; Compatibility section, XEmacs, Emacs -;; ====================================================================== - -;; FIXME It is bad practice to define compat functions with such generic names. - -(unless (fboundp 'match-string-no-properties) - (defalias 'match-string-no-properties 'match-string)) - -(when (featurep 'xemacs) - (unless (fboundp 'replace-regexp-in-string) - (defun replace-regexp-in-string (re rp st) - (save-match-data ;; apparently XEmacs needs save-match-data - (replace-in-string st re rp))))) - -;; copied from subr.el -(unless (fboundp 'add-to-invisibility-spec) - (defun add-to-invisibility-spec (arg) - "Add elements to `buffer-invisibility-spec'. -See documentation for `buffer-invisibility-spec' for the kind of elements -that can be added." - (if (eq buffer-invisibility-spec t) - (setq buffer-invisibility-spec (list t))) - (setq buffer-invisibility-spec - (cons arg buffer-invisibility-spec)))) - -;; copied from subr.el -(unless (fboundp 'remove-from-invisibility-spec) - (defun remove-from-invisibility-spec (arg) - "Remove elements from `buffer-invisibility-spec'." - (if (consp buffer-invisibility-spec) - (setq buffer-invisibility-spec - (delete arg buffer-invisibility-spec))))) - -;; ====================================================================== ;;; Internal variables ;; ====================================================================== (defvar newsticker--buffer-uptodate-p nil @@ -591,11 +557,6 @@ name/timer pair to `newsticker--retrieval-timer-list'." ;; do not repeat retrieval if interval not positive (if (<= interval 0) (setq interval nil)) - ;; Suddenly XEmacs doesn't like start-time 0 - (if (or (not start-time) - (and (numberp start-time) (= start-time 0))) - (setq start-time 1)) - ;; (message "start-time %s" start-time) (setq timer (run-at-time start-time interval 'newsticker-get-news feed-name)) (if interval @@ -603,7 +564,7 @@ name/timer pair to `newsticker--retrieval-timer-list'." (cons feed-name timer)))))) ;;;###autoload -(defun newsticker-start (&optional do-not-complain-if-running) +(defun newsticker-start (&optional _do-not-complain-if-running) "Start the newsticker. Start the timers for display and retrieval. If the newsticker, i.e. the timers, are running already a warning message is printed unless @@ -639,9 +600,8 @@ if newsticker has been running." (when (fboundp 'newsticker-stop-ticker) ; silence compiler warnings (newsticker-stop-ticker)) (when (newsticker-running-p) - (mapc (lambda (name-and-timer) - (newsticker--stop-feed (car name-and-timer))) - newsticker--retrieval-timer-list) + (dolist (name-and-timer newsticker--retrieval-timer-list) + (newsticker--stop-feed (car name-and-timer))) (setq newsticker--retrieval-timer-list nil) (run-hooks 'newsticker-stop-hook) (message "Newsticker stopped!"))) @@ -651,9 +611,8 @@ if newsticker has been running." This does NOT start the retrieval timers." (interactive) ;; launch retrieval of news - (mapc (lambda (item) - (newsticker-get-news (car item))) - (append newsticker-url-list-defaults newsticker-url-list))) + (dolist (item (append newsticker-url-list-defaults newsticker-url-list)) + (newsticker-get-news (car item)))) (defun newsticker-save-item (feed item) "Save FEED ITEM." @@ -709,7 +668,7 @@ See `newsticker-get-news'." (let ((buffername (concat " *newsticker-funcall-" feed-name "*"))) (with-current-buffer (get-buffer-create buffername) (erase-buffer) - (insert (string-to-multibyte (funcall function feed-name))) + (newsticker--insert-bytes (funcall function feed-name)) (newsticker--sentinel-work nil t feed-name function (current-buffer))))) @@ -730,10 +689,10 @@ STATUS is the return status as delivered by `url-retrieve', and FEED-NAME is the name of the feed that the news were retrieved from." (let ((buf (get-buffer-create (concat " *newsticker-url-" feed-name "*"))) - (result (string-to-multibyte (buffer-string)))) + (result (buffer-string))) (set-buffer buf) (erase-buffer) - (insert result) + (newsticker--insert-bytes result) ;; remove MIME header (goto-char (point-min)) (search-forward "\n\n" nil t) @@ -876,11 +835,12 @@ Argument BUFFER is the buffer of the retrieval process." (decode-coding-region (point-min) (point-max) coding-system)) (condition-case errordata - ;; The xml parser might fail or the xml might be - ;; bugged + ;; The xml parser might fail or the xml might be bugged. (if (fboundp 'libxml-parse-xml-region) - (list (libxml-parse-xml-region (point-min) (point-max) - nil t)) + (progn + (xml-remove-comments (point-min) (point-max)) + (list (libxml-parse-xml-region (point-min) (point-max) + nil))) (xml-parse-region (point-min) (point-max))) (error (message "Could not parse %s: %s" (buffer-name) (cadr errordata)) @@ -1255,9 +1215,6 @@ For the RSS 0.91 specification see URL `http://backend.userland.com/rss091' or URL `http://my.netscape.com/publish/formats/rss-spec-0.91.html'." (newsticker--debug-msg "Parsing RSS 0.91 feed %s" name) (let* ((channelnode (car (xml-get-children topnode 'channel))) - (pub-date (newsticker--decode-rfc822-date - (car (xml-node-children - (car (xml-get-children channelnode 'pubDate)))))) is-new-feed has-new-items) (setq is-new-feed (newsticker--parse-generic-feed name time @@ -1293,7 +1250,7 @@ or URL `http://my.netscape.com/publish/formats/rss-spec-0.91.html'." (car (xml-node-children (car (xml-get-children node 'pubDate)))))) ;; guid-fn - (lambda (node) + (lambda (_node) nil) ;; extra-fn (lambda (node) @@ -1308,9 +1265,6 @@ same as in `newsticker--parse-atom-1.0'. For the RSS 0.92 specification see URL `http://backend.userland.com/rss092'." (newsticker--debug-msg "Parsing RSS 0.92 feed %s" name) (let* ((channelnode (car (xml-get-children topnode 'channel))) - (pub-date (newsticker--decode-rfc822-date - (car (xml-node-children - (car (xml-get-children channelnode 'pubDate)))))) is-new-feed has-new-items) (setq is-new-feed (newsticker--parse-generic-feed name time @@ -1346,7 +1300,7 @@ For the RSS 0.92 specification see URL `http://backend.userland.com/rss092'." (car (xml-node-children (car (xml-get-children node 'pubDate)))))) ;; guid-fn - (lambda (node) + (lambda (_node) nil) ;; extra-fn (lambda (node) @@ -1405,7 +1359,7 @@ For the RSS 1.0 specification see URL `http://web.resource.org/rss/1.0/spec'." (car (xml-node-children (car (xml-get-children node 'date))))))) ;; guid-fn - (lambda (node) + (lambda (_node) nil) ;; extra-fn (lambda (node) @@ -1486,7 +1440,6 @@ The arguments TITLE, DESC, LINK, and EXTRA-ELEMENTS give the feed's title, description, link, and extra elements resp." (let ((title (or title "[untitled]")) (link (or link "")) - (old-item nil) (position 0) (something-was-added nil)) ;; decode numeric entities @@ -1522,89 +1475,89 @@ The arguments TITLE-FN, DESC-FN, LINK-FN, TIME-FN, GUID-FN, and EXTRA-FN give functions for extracting title, description, link, time, guid, and extra-elements resp. They are called with one argument, which is one of the items in ITEMLIST." - (let (title desc link - (old-item nil) - (position 0) + (let ((position 0) (something-was-added nil)) ;; gather all items for this feed - (mapc (lambda (node) - (setq position (1+ position)) - (setq title (or (funcall title-fn node) "[untitled]")) - (setq desc (funcall desc-fn node)) - (setq link (or (funcall link-fn node) "")) - (setq time (or (funcall time-fn node) time)) - ;; It happened that the title or description - ;; contained evil HTML code that confused the - ;; xml parser. Therefore: - (unless (stringp title) - (setq title (prin1-to-string title))) - (unless (or (stringp desc) (not desc)) - (setq desc (prin1-to-string desc))) - ;; ignore items with empty title AND empty desc - (when (or (> (length title) 0) - (> (length desc) 0)) - ;; decode numeric entities - (setq title (xml-substitute-numeric-entities title)) - (when desc - (setq desc (xml-substitute-numeric-entities desc))) - (setq link (xml-substitute-numeric-entities link)) - ;; remove whitespace from title, desc, and link - (setq title (newsticker--remove-whitespace title)) - (setq desc (newsticker--remove-whitespace desc)) - (setq link (newsticker--remove-whitespace link)) - ;; add data to cache - ;; do we have this item already? - (let* ((guid (funcall guid-fn node))) - ;;(message "guid=%s" guid) - (setq old-item - (newsticker--cache-contains newsticker--cache - (intern name) title - desc link nil guid))) - ;; add this item, or mark it as old, or do nothing - (let ((age1 'new) - (age2 'old) - (item-new-p nil)) - (if old-item - (let ((prev-age (newsticker--age old-item))) - (unless newsticker-automatically-mark-items-as-old - ;; Some feeds deliver items multiply, the - ;; first time we find an 'obsolete-old one in - ;; the cache, the following times we find an - ;; 'old one - (if (memq prev-age '(obsolete-old old)) - (setq age2 'old) - (setq age2 'new))) - (if (eq prev-age 'immortal) - (setq age2 'immortal)) - (setq time (newsticker--time old-item))) - ;; item was not there - (setq item-new-p t) - (setq something-was-added t)) - (let ((extra-elements-with-guid (funcall extra-fn node))) - (unless (assoc 'guid extra-elements-with-guid) - (setq extra-elements-with-guid - (cons `(guid nil ,(funcall guid-fn node)) - extra-elements-with-guid))) - (setq newsticker--cache - (newsticker--cache-add - newsticker--cache (intern name) title desc link - time age1 position extra-elements-with-guid - time age2))) - (when item-new-p - (let ((item (newsticker--cache-contains - newsticker--cache (intern name) title - desc link nil))) - (if newsticker-auto-mark-filter-list - (newsticker--run-auto-mark-filter name item)) - (run-hook-with-args - 'newsticker-new-item-functions name item)))))) - itemlist) + (dolist (node itemlist) + (setq position (1+ position)) + (let ((title (or (funcall title-fn node) "[untitled]")) + (desc (funcall desc-fn node)) + (link (or (funcall link-fn node) ""))) + (setq time (or (funcall time-fn node) time)) + ;; It happened that the title or description + ;; contained evil HTML code that confused the + ;; xml parser. Therefore: + (unless (stringp title) + (setq title (prin1-to-string title))) + (unless (or (stringp desc) (not desc)) + (setq desc (prin1-to-string desc))) + ;; ignore items with empty title AND empty desc + (when (or (> (length title) 0) + (> (length desc) 0)) + ;; decode numeric entities + (setq title (xml-substitute-numeric-entities title)) + (when desc + (setq desc (xml-substitute-numeric-entities desc))) + (setq link (xml-substitute-numeric-entities link)) + ;; remove whitespace from title, desc, and link + (setq title (newsticker--remove-whitespace title)) + (setq desc (newsticker--remove-whitespace desc)) + (setq link (newsticker--remove-whitespace link)) + ;; add data to cache + ;; do we have this item already? + (let ((old-item + (let* ((guid (funcall guid-fn node))) + ;;(message "guid=%s" guid) + (newsticker--cache-contains newsticker--cache + (intern name) title + desc link nil guid))) + (age1 'new) + (age2 'old) + (item-new-p nil)) + ;; Add this item, or mark it as old, or do nothing + (if old-item + (let ((prev-age (newsticker--age old-item))) + (unless newsticker-automatically-mark-items-as-old + ;; Some feeds deliver items multiply, the + ;; first time we find an 'obsolete-old one in + ;; the cache, the following times we find an + ;; 'old one + (if (memq prev-age '(obsolete-old old)) + (setq age2 'old) + (setq age2 'new))) + (if (eq prev-age 'immortal) + (setq age2 'immortal)) + (setq time (newsticker--time old-item))) + ;; item was not there + (setq item-new-p t) + (setq something-was-added t)) + (let ((extra-elements-with-guid (funcall extra-fn node))) + (unless (assoc 'guid extra-elements-with-guid) + (setq extra-elements-with-guid + (cons `(guid nil ,(funcall guid-fn node)) + extra-elements-with-guid))) + (setq newsticker--cache + (newsticker--cache-add + newsticker--cache (intern name) title desc link + time age1 position extra-elements-with-guid + time age2))) + (when item-new-p + (let ((item (newsticker--cache-contains + newsticker--cache (intern name) title + desc link nil))) + (if newsticker-auto-mark-filter-list + (newsticker--run-auto-mark-filter name item)) + (run-hook-with-args + 'newsticker-new-item-functions name item))))))) something-was-added)) ;; ====================================================================== ;;; Misc ;; ====================================================================== +(defun newsticker--insert-bytes (bytes) + (insert (decode-coding-string bytes 'binary))) + (defun newsticker--remove-whitespace (string) "Remove leading and trailing whitespace from STRING." ;; we must have ...+ but not ...* in the regexps otherwise xemacs loops @@ -1759,12 +1712,11 @@ Sat, 07 Sep 2002 00:00:01 GMT (setq minute (+ minute offset-minute))))) (condition-case error-data (let ((i 1)) - (mapc (lambda (m) - (if (string= month-name m) - (setq month i)) - (setq i (1+ i))) - '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" - "Sep" "Oct" "Nov" "Dec")) + (dolist (m '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" + "Sep" "Oct" "Nov" "Dec")) + (if (string= month-name m) + (setq month i)) + (setq i (1+ i))) (encode-time second minute hour day month year t)) (error (message "Cannot decode \"%s\": %s %s" rfc822-string @@ -1775,22 +1727,19 @@ Sat, 07 Sep 2002 00:00:01 GMT (defun newsticker--lists-intersect-p (list1 list2) "Return t if LIST1 and LIST2 share elements." (let ((result nil)) - (mapc (lambda (elt) - (if (memq elt list2) - (setq result t))) - list1) + (dolist (elt list1) + (if (memq elt list2) + (setq result t))) result)) (defun newsticker--update-process-ids () "Update list of ids of active newsticker processes. Checks list of active processes against list of newsticker processes." - (let ((active-procs (process-list)) - (new-list nil)) - (mapc (lambda (proc) - (let ((id (process-id proc))) - (if (memq id newsticker--process-ids) - (setq new-list (cons id new-list))))) - active-procs) + (let ((new-list nil)) + (dolist (proc (process-list)) + (let ((id (process-id proc))) + (if (memq id newsticker--process-ids) + (setq new-list (cons id new-list))))) (setq newsticker--process-ids new-list)) (force-mode-line-update)) @@ -1811,9 +1760,10 @@ If the file does no exist or if it is older than 24 hours download it from URL first." (let ((image-name (concat directory feed-name))) (if (and (file-exists-p image-name) - (time-less-p (current-time) - (time-add (nth 5 (file-attributes image-name)) - (seconds-to-time 86400)))) + (time-less-p nil + (time-add (file-attribute-modification-time + (file-attributes image-name)) + 86400))) (newsticker--debug-msg "%s: Getting image for %s skipped" (format-time-string "%A, %H:%M") feed-name) @@ -1853,7 +1803,7 @@ Save image as FILENAME in DIRECTORY, download it from URL." (process-put proc 'nt-feed-name feed-name) (process-put proc 'nt-filename filename))))) -(defun newsticker--image-sentinel (process event) +(defun newsticker--image-sentinel (process _event) "Sentinel for image-retrieving PROCESS caused by EVENT." (let* ((p-status (process-status process)) (exit-status (process-exit-status process)) @@ -1914,21 +1864,21 @@ from. The image is saved in DIRECTORY as FILENAME." (let ((do-save (or (not status) - (let ((status-type (car status)) - (status-details (cdr status))) - (cond ((eq status-type :redirect) - ;; don't care about redirects - t) - ((eq status-type :error) - ;; silently ignore errors - nil)))))) + ;; (let ((status-type (car status))) + ;; (cond ((eq status-type :redirect) + ;; ;; don't care about redirects + ;; t) + ;; ((eq status-type :error) + ;; ;; silently ignore errors + ;; nil))) + (eq (car status) :redirect)))) (when do-save (let ((buf (get-buffer-create (concat " *newsticker-url-image-" feed-name "-" directory "*"))) - (result (string-to-multibyte (buffer-string)))) + (result (buffer-string))) (set-buffer buf) (erase-buffer) - (insert result) + (newsticker--insert-bytes result) ;; remove MIME header (goto-char (point-min)) (search-forward "\n\n") @@ -2006,9 +1956,8 @@ older than TIME." (mapc (lambda (item) (when (eq (newsticker--age item) old-age) - (let ((exp-time (time-add (newsticker--time item) - (seconds-to-time time)))) - (when (time-less-p exp-time (current-time)) + (let ((exp-time (time-add (newsticker--time item) time))) + (when (time-less-p exp-time nil) (newsticker--debug-msg "Item `%s' from %s has expired on %s" (newsticker--title item) @@ -2020,7 +1969,7 @@ older than TIME." data) data) -(defun newsticker--cache-contains (data feed title desc link age +(defun newsticker--cache-contains (data feed title desc link _age &optional guid) "Check DATA whether FEED contains an item with the given properties. This function returns the contained item or nil if it is not @@ -2182,22 +2131,8 @@ well." (throw 'result nil)) ((eq age2 'obsolete) (throw 'result t))))) - (let* ((time1 (newsticker--time item1)) - (time2 (newsticker--time item2))) - (cond ((< (nth 0 time1) (nth 0 time2)) - nil) - ((> (nth 0 time1) (nth 0 time2)) - t) - ((< (nth 1 time1) (nth 1 time2)) - nil) - ((> (nth 1 time1) (nth 1 time2)) - t) - ((< (or (nth 2 time1) 0) (or (nth 2 time2) 0)) - nil) - ((> (or (nth 2 time1) 0) (or (nth 2 time2) 0)) - t) - (t - nil))))) + (time-less-p (newsticker--time item2) + (newsticker--time item1)))) (defun newsticker--cache-item-compare-by-title (item1 item2) "Compare ITEM1 and ITEM2 by comparing their titles." @@ -2293,9 +2228,8 @@ FEED is a symbol!" (newsticker--cache-read-version1)) (when (y-or-n-p (format "Delete old newsticker cache file? ")) (delete-file newsticker-cache-filename))) - (mapc (lambda (f) - (newsticker--cache-read-feed (car f))) - (append newsticker-url-list-defaults newsticker-url-list)))) + (dolist (f (append newsticker-url-list-defaults newsticker-url-list)) + (newsticker--cache-read-feed (car f))))) (defun newsticker--cache-read-feed (feed-name) "Read cache data for feed named FEED-NAME." @@ -2362,14 +2296,13 @@ Export subscriptions to a buffer in OPML Format." " <ownerName>" (user-full-name) "</ownerName>\n" " </head>\n" " <body>\n")) - (mapc (lambda (sub) - (insert " <outline text=\"") - (insert (newsticker--title sub)) - (insert "\" xmlUrl=\"") - (insert (xml-escape-string (let ((url (cadr sub))) - (if (stringp url) url (prin1-to-string url))))) - (insert "\"/>\n")) - (append newsticker-url-list newsticker-url-list-defaults)) + (dolist (sub (append newsticker-url-list newsticker-url-list-defaults)) + (insert " <outline text=\"") + (insert (newsticker--title sub)) + (insert "\" xmlUrl=\"") + (insert (xml-escape-string (let ((url (cadr sub))) + (if (stringp url) url (prin1-to-string url))))) + (insert "\"/>\n")) (insert " </body>\n</opml>\n")) (pop-to-buffer "*OPML Export*") (when (fboundp 'sgml-mode) @@ -2409,28 +2342,26 @@ removed." This function checks the variable `newsticker-auto-mark-filter-list' for an entry that matches FEED and ITEM." (let ((case-fold-search t)) - (mapc (lambda (filter) - (let ((filter-feed (car filter)) - (pattern-list (cadr filter))) - (when (string-match filter-feed feed) - (newsticker--do-run-auto-mark-filter item pattern-list)))) - newsticker-auto-mark-filter-list))) + (dolist (filter newsticker-auto-mark-filter-list) + (let ((filter-feed (car filter)) + (pattern-list (cadr filter))) + (when (string-match filter-feed feed) + (newsticker--do-run-auto-mark-filter item pattern-list)))))) (defun newsticker--do-run-auto-mark-filter (item list) "Actually compare ITEM against the pattern-LIST. LIST must be an element of `newsticker-auto-mark-filter-list'." - (mapc (lambda (pattern) - (let ((place (nth 1 pattern)) - (regexp (nth 2 pattern)) - (title (newsticker--title item)) - (desc (newsticker--desc item))) - (when (or (eq place 'title) (eq place 'all)) - (when (and title (string-match regexp title)) - (newsticker--process-auto-mark-filter-match item pattern))) - (when (or (eq place 'description) (eq place 'all)) - (when (and desc (string-match regexp desc)) - (newsticker--process-auto-mark-filter-match item pattern))))) - list)) + (dolist (pattern list) + (let ((place (nth 1 pattern)) + (regexp (nth 2 pattern)) + (title (newsticker--title item)) + (desc (newsticker--desc item))) + (when (or (eq place 'title) (eq place 'all)) + (when (and title (string-match regexp title)) + (newsticker--process-auto-mark-filter-match item pattern))) + (when (or (eq place 'description) (eq place 'all)) + (when (and desc (string-match regexp desc)) + (newsticker--process-auto-mark-filter-match item pattern)))))) (defun newsticker--process-auto-mark-filter-match (item pattern) "Process ITEM that matches an auto-mark-filter PATTERN." @@ -2503,7 +2434,7 @@ This function is suited for adding it to `newsticker-new-item-functions'." ;; ====================================================================== ;;; Retrieve samples ;; ====================================================================== -(defun newsticker-retrieve-random-message (feed-name) +(defun newsticker-retrieve-random-message (_feed-name) "Return an artificial RSS string under the name FEED-NAME." (concat "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?><rss version=\"0.91\">" "<channel>" diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el index 569383b4a28..4f5c729dd00 100644 --- a/lisp/net/newst-plainview.el +++ b/lisp/net/newst-plainview.el @@ -562,7 +562,6 @@ This does NOT start the retrieval timers." (newsticker--debug-msg "Getting news for %s" (symbol-name feed)) (newsticker-get-news (symbol-name feed))))) -(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) (declare-function w3m-toggle-inline-image "ext:w3m" (&optional force no-cache)) (defun newsticker-w3m-show-inline-images () diff --git a/lisp/net/newst-treeview.el b/lisp/net/newst-treeview.el index 3af2c423be9..ece728a8358 100644 --- a/lisp/net/newst-treeview.el +++ b/lisp/net/newst-treeview.el @@ -36,6 +36,7 @@ ;; ====================================================================== ;;; Code: +(require 'cl-lib) (require 'newst-reader) (require 'widget) (require 'tree-widget) @@ -258,7 +259,6 @@ their id stays constant." ;; ====================================================================== -(unless (fboundp 'declare-function) (defmacro declare-function (&rest _))) (declare-function w3m-toggle-inline-images "ext:w3m" (&optional force no-cache)) (defvar w3m-fill-column) (defvar w3-maximum-line-length) diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index 13e6b08e2fc..dbfa2101f0c 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -26,6 +26,7 @@ (require 'cl-lib) (require 'rmc) ; read-multiple-choice +(eval-when-compile (require 'subr-x)) (defvar nsm-permanent-host-settings nil) (defvar nsm-temporary-host-settings nil) @@ -118,12 +119,10 @@ unencrypted." process)))))) (defun nsm-check-tls-connection (process host port status settings) - (let ((process (nsm-check-certificate process host port status settings))) - (if (and process - (>= (nsm-level network-security-level) (nsm-level 'high))) - ;; Do further protocol-level checks if the security is high. - (nsm-check-protocol process host port status settings) - process))) + (when-let ((process + (nsm-check-certificate process host port status settings))) + ;; Do further protocol-level checks. + (nsm-check-protocol process host port status settings))) (declare-function gnutls-peer-status-warning-describe "gnutls.c" (status-symbol)) @@ -150,11 +149,6 @@ unencrypted." (not (nsm-new-fingerprint-ok-p host port status))) (delete-process process) nil) - ((>= (nsm-level network-security-level) (nsm-level 'high)) - ;; Save the host fingerprint so that we can check it the - ;; next time we connect. - (nsm-save-host host port status 'fingerprint 'always) - process) (t process))) @@ -182,57 +176,104 @@ unencrypted." nil) process)))))) +(defvar network-security-protocol-checks + '((diffie-hellman-prime-bits medium 1024) + (rc4 medium) + (signature-sha1 medium) + (intermediate-sha1 medium) + (3des high) + (ssl medium)) + "This variable specifies what TLS connection checks to perform. +It's an alist where the first element is the name of the check, +the second is the security level where the check kicks in, and the +optional third element is a parameter supplied to the check. + +An element like `(rc4 medium)' will result in the function +`nsm-protocol-check--rc4' being called with the parameters +HOST PORT STATUS OPTIONAL-PARAMETER.") + (defun nsm-check-protocol (process host port status settings) - (let ((prime-bits (plist-get status :diffie-hellman-prime-bits)) - (signature-algorithm - (plist-get (plist-get status :certificate) :signature-algorithm)) - (encryption (format "%s-%s-%s" - (plist-get status :key-exchange) - (plist-get status :cipher) - (plist-get status :mac))) - (protocol (plist-get status :protocol))) - (cond - ((and prime-bits - (< prime-bits 1024) - (not (memq :diffie-hellman-prime-bits - (plist-get settings :conditions))) - (not - (nsm-query - host port status :diffie-hellman-prime-bits - "The Diffie-Hellman prime bits (%s) used for this connection to %s:%s is less than what is considered safe (%s)." - prime-bits host port 1024))) - (delete-process process) - nil) - ((and (string-match "\\bRC4\\b" encryption) - (not (memq :rc4 (plist-get settings :conditions))) - (not - (nsm-query - host port status :rc4 - "The connection to %s:%s uses the RC4 algorithm (%s), which is believed to be unsafe." - host port encryption))) - (delete-process process) - nil) - ((and (string-match "\\bSHA1\\b" signature-algorithm) - (not (memq :signature-sha1 (plist-get settings :conditions))) - (not - (nsm-query - host port status :signature-sha1 - "The certificate used to verify the connection to %s:%s uses the SHA1 algorithm (%s), which is believed to be unsafe." - host port signature-algorithm))) - (delete-process process) - nil) - ((and protocol - (string-match "SSL" protocol) - (not (memq :ssl (plist-get settings :conditions))) - (not - (nsm-query - host port status :ssl - "The connection to %s:%s uses the %s protocol, which is believed to be unsafe." - host port protocol))) - (delete-process process) - nil) - (t - process)))) + (cl-loop for check in network-security-protocol-checks + for type = (intern (format ":%s" (car check)) obarray) + while process + ;; Skip the check if the user has already said that this + ;; host is OK for this type of "error". + when (and (not (memq type (plist-get settings :conditions))) + (>= (nsm-level network-security-level) + (nsm-level (cadr check)))) + do (let ((result + (funcall (intern (format "nsm-protocol-check--%s" + (car check)) + obarray) + host port status (nth 2 check)))) + (unless result + (delete-process process) + (setq process nil)))) + ;; If a test failed we return nil, otherwise the process object. + process) + +(defun nsm--encryption (status) + (format "%s-%s-%s" + (plist-get status :key-exchange) + (plist-get status :cipher) + (plist-get status :mac))) + +(defun nsm-protocol-check--diffie-hellman-prime-bits (host port status bits) + (let ((prime-bits (plist-get status :diffie-hellman-prime-bits))) + (or (not prime-bits) + (>= prime-bits bits) + (nsm-query + host port status :diffie-hellman-prime-bits + "The Diffie-Hellman prime bits (%s) used for this connection to %s:%s is less than what is considered safe (%s)." + prime-bits host port bits)))) + +(defun nsm-protocol-check--3des (host port status _) + (or (not (string-match "\\b3DES\\b" (plist-get status :cipher))) + (nsm-query + host port status :rc4 + "The connection to %s:%s uses the 3DES cipher (%s), which is believed to be unsafe." + host port (plist-get status :cipher)))) + +(defun nsm-protocol-check--rc4 (host port status _) + (or (not (string-match "\\bRC4\\b" (nsm--encryption status))) + (nsm-query + host port status :rc4 + "The connection to %s:%s uses the RC4 algorithm (%s), which is believed to be unsafe." + host port (nsm--encryption status)))) + +(defun nsm-protocol-check--signature-sha1 (host port status _) + (let ((signature-algorithm + (plist-get (plist-get status :certificate) :signature-algorithm))) + (or (not (string-match "\\bSHA1\\b" signature-algorithm)) + (nsm-query + host port status :signature-sha1 + "The certificate used to verify the connection to %s:%s uses the SHA1 algorithm (%s), which is believed to be unsafe." + host port signature-algorithm)))) + +(defun nsm-protocol-check--intermediate-sha1 (host port status _) + ;; Skip the first certificate, because that's the host certificate. + (cl-loop for certificate in (cdr (plist-get status :certificates)) + for algo = (plist-get certificate :signature-algorithm) + ;; Don't check root certificates -- SHA1 isn't dangerous + ;; there. + when (and (not (equal (plist-get certificate :issuer) + (plist-get certificate :subject))) + (string-match "\\bSHA1\\b" algo) + (not (nsm-query + host port status :intermediate-sha1 + "An intermediate certificate used to verify the connection to %s:%s uses the SHA1 algorithm (%s), which is believed to be unsafe." + host port algo))) + do (cl-return nil) + finally (cl-return t))) + +(defun nsm-protocol-check--ssl (host port status _) + (let ((protocol (plist-get status :protocol))) + (or (not protocol) + (not (string-match "SSL" protocol)) + (nsm-query + host port status :ssl + "The connection to %s:%s uses the %s protocol, which is believed to be unsafe." + host port protocol)))) (defun nsm-fingerprint (status) (plist-get (plist-get status :certificate) :public-key-id)) diff --git a/lisp/net/ntlm.el b/lisp/net/ntlm.el index d3899e45eae..88c561910cb 100644 --- a/lisp/net/ntlm.el +++ b/lisp/net/ntlm.el @@ -1,4 +1,4 @@ -;;; ntlm.el --- NTLM (NT LanManager) authentication support +;;; ntlm.el --- NTLM (NT LanManager) authentication support -*- lexical-binding:t -*- ;; Copyright (C) 2001, 2007-2019 Free Software Foundation, Inc. @@ -106,7 +106,7 @@ is not given." (request-flags (concat (make-string 1 7) (make-string 1 130) (make-string 1 8) (make-string 1 0))) ;0x07 0x82 0x08 0x00 - lu ld off-d off-u) + ) (when (and user (string-match "@" user)) (unless domain (setq domain (substring user (1+ (match-beginning 0))))) @@ -115,10 +115,10 @@ is not given." ;; set "negotiate domain supplied" bit (aset request-flags 1 (logior (aref request-flags 1) ?\x10))) ;; set fields offsets within the request struct - (setq lu (length user)) - (setq ld (length domain)) - (setq off-u 32) ;offset to the string 'user - (setq off-d (+ 32 lu)) ;offset to the string 'domain + (let* ((lu (length user)) + (ld (length domain)) + (off-u 32) ;offset to the string 'user + (off-d (+ 32 lu))) ;offset to the string 'domain ;; pack the request struct in a string (concat request-ident ;8 bytes request-msgType ;4 bytes @@ -131,39 +131,34 @@ is not given." (md4-pack-int32 (cons 0 off-d)) ;domain field, offset field user ;buffer field domain ;buffer field - ))) - -(eval-when-compile - (defmacro ntlm-string-as-unibyte (string) - (if (fboundp 'string-as-unibyte) - `(string-as-unibyte ,string) - string))) + )))) (defun ntlm-compute-timestamp () "Compute an NTLMv2 timestamp. Return a unibyte string representing the number of tenths of a microsecond since January 1, 1601 as a 64-bit little-endian signed integer." + ;; FIXME: This can likely be significantly simplified using the new + ;; bignums support! (let* ((s-to-tenths-of-us "mul(add(lsh($1,16),$2),10000000)") (us-to-tenths-of-us "mul($3,10)") (ps-to-tenths-of-us "idiv($4,100000)") (tenths-of-us-since-jan-1-1601 - (apply 'calc-eval (concat "add(add(add(" + (apply #'calc-eval (concat "add(add(add(" s-to-tenths-of-us "," us-to-tenths-of-us ")," ps-to-tenths-of-us ")," ;; tenths of microseconds between ;; 1601-01-01 and 1970-01-01 "116444736000000000)") - ;; add trailing zeros to support old current-time formats - 'rawnum (append (current-time) '(0 0)))) + 'rawnum (encode-time nil 'list))) result-bytes) - (dotimes (byte 8) + (dotimes (_byte 8) (push (calc-eval "and($1,16#FF)" 'rawnum tenths-of-us-since-jan-1-1601) result-bytes) (setq tenths-of-us-since-jan-1-1601 (calc-eval "rsh($1,8,64)" 'rawnum tenths-of-us-since-jan-1-1601))) - (apply 'unibyte-string (nreverse result-bytes)))) + (apply #'unibyte-string (nreverse result-bytes)))) (defun ntlm-generate-nonce () "Generate a random nonce, not to be used more than once. @@ -178,7 +173,13 @@ the NTLM based server for the user USER and the password hash list PASSWORD-HASHES. NTLM uses two hash values which are represented by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of (list (ntlm-smb-passwd-hash password) (ntlm-md4hash password))" - (let* ((rchallenge (ntlm-string-as-unibyte challenge)) + (let* ((rchallenge (if (multibyte-string-p challenge) + (progn + ;; FIXME: Maybe it would be better to + ;; signal an error. + (message "Incorrect challenge string type in ntlm-build-auth-response") + (encode-coding-string challenge 'binary)) + challenge)) ;; get fields within challenge struct ;;(ident (substring rchallenge 0 8)) ;ident, 8 bytes ;;(msgType (substring rchallenge 8 12)) ;msgType, 4 bytes @@ -189,20 +190,16 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of ;0x07 0x82 0x08 0x00 (flags (substring rchallenge 20 24)) ;flags, 4 bytes (challengeData (substring rchallenge 24 32)) ;challengeData, 8 bytes - uDomain-len uDomain-offs - ;; response struct and its fields + ;; Extract domain string from challenge string. + ;;(uDomain-len (md4-unpack-int16 (substring uDomain 0 2))) + (uDomain-offs (md4-unpack-int32 (substring uDomain 4 8))) + ;; Response struct and its fields. lmRespData ;lmRespData, 24 bytes ntRespData ;ntRespData, variable length - domain ;ascii domain string - workstation ;ascii workstation string - ll ln lu ld lw off-lm off-nt off-u off-d off-w) - ;; extract domain string from challenge string - (setq uDomain-len (md4-unpack-int16 (substring uDomain 0 2))) - (setq uDomain-offs (md4-unpack-int32 (substring uDomain 4 8))) - ;; match Mozilla behavior, which is to send an empty domain string - (setq domain "") - ;; match Mozilla behavior, which is to send "WORKSTATION" - (setq workstation "WORKSTATION") + ;; Match Mozilla behavior, which is to send an empty domain string + (domain "") ;ascii domain string + ;; Match Mozilla behavior, which is to send "WORKSTATION". + (workstation "WORKSTATION")) ;ascii workstation string ;; overwrite domain in case user is given in <user>@<domain> format (when (string-match "@" user) (setq domain (substring user (1+ (match-beginning 0)))) @@ -261,13 +258,11 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of ;; so just treat it the same as levels 0 and 1 ;; check if "negotiate NTLM2 key" flag is set in type 2 message (if (not (zerop (logand (aref flags 2) 8))) - (let (randomString - sessionHash) - ;; generate NTLM2 session response data - (setq randomString (ntlm-generate-nonce)) - (setq sessionHash (secure-hash 'md5 + ;; generate NTLM2 session response data + (let* ((randomString (ntlm-generate-nonce)) + (sessionHash (secure-hash 'md5 (concat challengeData randomString) - nil nil t)) + nil nil t))) (setq sessionHash (substring sessionHash 0 8)) (setq lmRespData (concat randomString (make-string 16 0))) (setq ntRespData (ntlm-smb-owf-encrypt @@ -279,16 +274,16 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of (ntlm-smb-owf-encrypt (cadr password-hashes) challengeData)))) ;; get offsets to fields to pack the response struct in a string - (setq ll (length lmRespData)) - (setq ln (length ntRespData)) - (setq lu (length user)) - (setq ld (length domain)) - (setq lw (length workstation)) - (setq off-u 64) ;offset to string 'uUser - (setq off-d (+ off-u (* 2 lu))) ;offset to string 'uDomain - (setq off-w (+ off-d (* 2 ld))) ;offset to string 'uWks - (setq off-lm (+ off-w (* 2 lw))) ;offset to string 'lmResponse - (setq off-nt (+ off-lm ll)) ;offset to string 'ntResponse + (let* ((ll (length lmRespData)) + (ln (length ntRespData)) + (lu (length user)) + (ld (length domain)) + (lw (length workstation)) + (off-u 64) ;offset to string 'uUser + (off-d (+ off-u (* 2 lu))) ;offset to string 'uDomain + (off-w (+ off-d (* 2 ld))) ;offset to string 'uWks + (off-lm (+ off-w (* 2 lw))) ;offset to string 'lmResponse + (off-nt (+ off-lm ll))) ;offset to string 'ntResponse ;; pack the response struct in a string (concat "NTLMSSP\0" ;response ident field, 8 bytes (md4-pack-int32 '(0 . 3)) ;response msgType field, 4 bytes @@ -342,7 +337,7 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of (ntlm-ascii2unicode workstation lw) ;Unicode workstation, 2*lw bytes lmRespData ;lmResponse, 24 bytes ntRespData ;ntResponse, ln bytes - ))) + )))) (defun ntlm-get-password-hashes (password) "Return a pair of SMB hash and NT MD4 hash of the given password PASSWORD." @@ -352,7 +347,10 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of (defun ntlm-ascii2unicode (str len) "Convert an ASCII string into a NT Unicode string, which is little-endian utf16." - (let ((utf (make-string (* 2 len) 0)) (i 0) val) + ;; FIXME: Can't we use encode-coding-string with a `utf-16le' coding system? + (let ((utf (make-string (* 2 len) 0)) + (i 0) + val) (while (and (< i len) (not (zerop (setq val (aref str i))))) (aset utf (* 2 i) val) @@ -381,9 +379,9 @@ string PASSWD. PASSWD is truncated to 14 bytes if longer." "Return the response string of 24 bytes long for the given password string PASSWD based on the DES encryption. PASSWD is of at most 14 bytes long and the challenge string C8 of 8 bytes long." - (let ((len (min (length passwd) 16)) p22) - (setq p22 (concat (substring passwd 0 len) ;fill top 16 bytes with passwd - (make-string (- 22 len) 0))) + (let* ((len (min (length passwd) 16)) + (p22 (concat (substring passwd 0 len) ;Fill top 16 bytes with passwd. + (make-string (- 22 len) 0)))) (ntlm-smb-des-e-p24 p22 c8))) (defun ntlm-smb-des-e-p24 (p22 c8) @@ -405,53 +403,53 @@ string C8." "Return the hash string of length 8 for a string IN of length 8 and a string KEY of length 8. FORW is t or nil." (let ((out (make-string 8 0)) - outb ;string of length 64 (inb (make-string 64 0)) (keyb (make-string 64 0)) (key2 (ntlm-smb-str-to-key key)) - (i 0) aa) + (i 0)) (while (< i 64) - (unless (zerop (logand (aref in (/ i 8)) (lsh 1 (- 7 (% i 8))))) + (unless (zerop (logand (aref in (/ i 8)) (ash 1 (- 7 (% i 8))))) (aset inb i 1)) - (unless (zerop (logand (aref key2 (/ i 8)) (lsh 1 (- 7 (% i 8))))) + (unless (zerop (logand (aref key2 (/ i 8)) (ash 1 (- 7 (% i 8))))) (aset keyb i 1)) (setq i (1+ i))) - (setq outb (ntlm-smb-dohash inb keyb forw)) - (setq i 0) - (while (< i 64) - (unless (zerop (aref outb i)) - (setq aa (aref out (/ i 8))) - (aset out (/ i 8) - (logior aa (lsh 1 (- 7 (% i 8)))))) - (setq i (1+ i))) - out)) + (let ((outb (ntlm-smb-dohash inb keyb forw)) + aa) + (setq i 0) + (while (< i 64) + (unless (zerop (aref outb i)) + (setq aa (aref out (/ i 8))) + (aset out (/ i 8) + (logior aa (ash 1 (- 7 (% i 8)))))) + (setq i (1+ i))) + out))) (defun ntlm-smb-str-to-key (str) "Return a string of length 8 for the given string STR of length 7." (let ((key (make-string 8 0)) (i 7)) - (aset key 0 (lsh (aref str 0) -1)) + (aset key 0 (ash (aref str 0) -1)) (aset key 1 (logior - (lsh (logand (aref str 0) 1) 6) - (lsh (aref str 1) -2))) + (ash (logand (aref str 0) 1) 6) + (ash (aref str 1) -2))) (aset key 2 (logior - (lsh (logand (aref str 1) 3) 5) - (lsh (aref str 2) -3))) + (ash (logand (aref str 1) 3) 5) + (ash (aref str 2) -3))) (aset key 3 (logior - (lsh (logand (aref str 2) 7) 4) - (lsh (aref str 3) -4))) + (ash (logand (aref str 2) 7) 4) + (ash (aref str 3) -4))) (aset key 4 (logior - (lsh (logand (aref str 3) 15) 3) - (lsh (aref str 4) -5))) + (ash (logand (aref str 3) 15) 3) + (ash (aref str 4) -5))) (aset key 5 (logior - (lsh (logand (aref str 4) 31) 2) - (lsh (aref str 5) -6))) + (ash (logand (aref str 4) 31) 2) + (ash (aref str 5) -6))) (aset key 6 (logior - (lsh (logand (aref str 5) 63) 1) - (lsh (aref str 6) -7))) + (ash (logand (aref str 5) 63) 1) + (ash (aref str 6) -7))) (aset key 7 (logand (aref str 6) 127)) (while (>= i 0) - (aset key i (lsh (aref key i) 1)) + (aset key i (ash (aref key i) 1)) (setq i (1- i))) key)) @@ -571,27 +569,22 @@ length of STR is LEN." "Return the hash value for a string IN and a string KEY. Length of IN and KEY are 64. FORW non-nil means forward, nil means backward." - (let (pk1 ;string of length 56 - c ;string of length 28 - d ;string of length 28 - cd ;string of length 56 - (ki (make-vector 16 0)) ;vector of string of length 48 - pd1 ;string of length 64 - l ;string of length 32 - r ;string of length 32 - rl ;string of length 64 - (i 0) (j 0) (k 0)) - (setq pk1 (ntlm-string-permute key ntlm-smb-perm1 56)) - (setq c (substring pk1 0 28)) - (setq d (substring pk1 28 56)) - - (setq i 0) - (while (< i 16) + (let* ((pk1 (ntlm-string-permute key ntlm-smb-perm1 56)) ;string of length 56 + (c (substring pk1 0 28)) ;string of length 28 + (d (substring pk1 28 56)) ;string of length 28 + cd ;string of length 56 + (ki (make-vector 16 0)) ;vector of string of length 48 + pd1 ;string of length 64 + l ;string of length 32 + r ;string of length 32 + rl ;string of length 64 + (i 0) (j 0) (k 0)) + + (dotimes (i 16) (setq c (ntlm-string-lshift c (aref ntlm-smb-sc i) 28)) (setq d (ntlm-string-lshift d (aref ntlm-smb-sc i) 28)) (setq cd (concat (substring c 0 28) (substring d 0 28))) - (aset ki i (ntlm-string-permute cd ntlm-smb-perm2 48)) - (setq i (1+ i))) + (aset ki i (ntlm-string-permute cd ntlm-smb-perm2 48))) (setq pd1 (ntlm-string-permute in ntlm-smb-perm3 64)) @@ -619,16 +612,16 @@ backward." (setq j 0) (while (< j 8) (setq bj (aref b j)) - (setq m (logior (lsh (aref bj 0) 1) (aref bj 5))) - (setq n (logior (lsh (aref bj 1) 3) - (lsh (aref bj 2) 2) - (lsh (aref bj 3) 1) + (setq m (logior (ash (aref bj 0) 1) (aref bj 5))) + (setq n (logior (ash (aref bj 1) 3) + (ash (aref bj 2) 2) + (ash (aref bj 3) 1) (aref bj 4))) (setq k 0) (setq sbox-jmn (aref (aref (aref ntlm-smb-sbox j) m) n)) (while (< k 4) (aset bj k - (if (zerop (logand sbox-jmn (lsh 1 (- 3 k)))) + (if (zerop (logand sbox-jmn (ash 1 (- 3 k)))) 0 1)) (setq k (1+ k))) (setq j (1+ j))) @@ -650,16 +643,12 @@ backward." (defun ntlm-md4hash (passwd) "Return the 16 bytes MD4 hash of a string PASSWD after converting it into a Unicode string. PASSWD is truncated to 128 bytes if longer." - (let (len wpwd) - ;; Password cannot be longer than 128 characters - (setq len (length passwd)) - (if (> len 128) - (setq len 128)) - ;; Password must be converted to NT Unicode - (setq wpwd (ntlm-ascii2unicode passwd len)) - ;; Calculate length in bytes - (setq len (* len 2)) - (md4 wpwd len))) + (let* ((len (min (length passwd) 128)) ;Pwd can't be > than 128 characters. + ;; Password must be converted to NT Unicode. + (wpwd (ntlm-ascii2unicode passwd len))) + (md4 wpwd + ;; Calculate length in bytes. + (* len 2)))) (provide 'ntlm) diff --git a/lisp/net/pop3.el b/lisp/net/pop3.el index f73607081c5..ddb4139610e 100644 --- a/lisp/net/pop3.el +++ b/lisp/net/pop3.el @@ -1,4 +1,4 @@ -;;; pop3.el --- Post Office Protocol (RFC 1460) interface +;;; pop3.el --- Post Office Protocol (RFC 1460) interface -*- lexical-binding:t -*- ;; Copyright (C) 1996-2019 Free Software Foundation, Inc. @@ -32,7 +32,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'mail-utils) (defvar parse-time-months) @@ -165,12 +165,7 @@ Used for APOP authentication.") "How long pop3 should wait between checking for the end of output. Shorter values mean quicker response, but are more CPU intensive.") (defun pop3-accept-process-output (process) - (accept-process-output - process - (truncate pop3-read-timeout) - (truncate (* (- pop3-read-timeout - (truncate pop3-read-timeout)) - 1000)))))) + (accept-process-output process pop3-read-timeout)))) (defvar pop3-uidl) ;; List of UIDLs of existing messages at present in the server: @@ -185,8 +180,8 @@ Shorter values mean quicker response, but are more CPU intensive.") ;; ("SERVER_B" ("USER_B1" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...) ;; ("USER_B2" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...) ;; ...)) -;; Where TIMESTAMP is the most significant two digits of an Emacs time, -;; i.e. the return value of `current-time'. +;; Where TIMESTAMP is an Emacs time value (HI LO) representing the +;; number of seconds (+ (ash HI 16) LO). ;;;###autoload (defun pop3-movemail (file) @@ -237,8 +232,8 @@ Use streaming commands." (setq start-point (pop3-wait-for-messages process pop3-stream-length total-size start-point)) - (incf waited-for pop3-stream-length)) - (incf i)) + (cl-incf waited-for pop3-stream-length)) + (cl-incf i)) (pop3-wait-for-messages process (- count waited-for) total-size start-point))) @@ -249,7 +244,7 @@ Use streaming commands." (or (not total-size) (re-search-forward "^\\.\r?\n" nil t))) (re-search-forward "^-ERR " nil t)) - (decf count) + (cl-decf count) (setq start-point (point))) (unless (memq (process-status process) '(open run)) (error "pop3 process died")) @@ -269,7 +264,6 @@ Use streaming commands." (defun pop3-write-to-file (file messages) (let ((pop-buffer (current-buffer)) - (start (point-min)) beg end temp-buffer) (with-temp-buffer @@ -280,7 +274,6 @@ Use streaming commands." (forward-line 1) (setq beg (point)) (when (re-search-forward "^\\.\r?\n" nil t) - (setq start (point)) (forward-line -1) (setq end (point))) (with-current-buffer temp-buffer @@ -369,7 +362,7 @@ Use streaming commands." (while (> i 0) (unless (member (nth (1- i) pop3-uidl) saved) (push i messages)) - (decf i))) + (cl-decf i))) (when messages (setq list (pop3-list process) size 0) @@ -387,7 +380,9 @@ Use streaming commands." (defun pop3-uidl-dele (process) "Delete messages according to `pop3-leave-mail-on-server'. Return non-nil if it is necessary to update the local UIDL file." - (let* ((ctime (current-time)) + (let* ((ctime (encode-time nil 'list)) + (age-limit (and (numberp pop3-leave-mail-on-server) + (* 86400 pop3-leave-mail-on-server))) (srvr (assoc pop3-mailhost pop3-uidl-saved)) (saved (assoc pop3-maildrop (cdr srvr))) i uidl mod new tstamp dele) @@ -399,22 +394,18 @@ Return non-nil if it is necessary to update the local UIDL file." (unless (member (setq uidl (nth i pop3-uidl)) (cdr saved)) (push ctime new) (push uidl new)) - (decf i))) + (cl-decf i))) (pop3-uidl (setq new (mapcan (lambda (elt) (list elt ctime)) pop3-uidl)))) (when new (setq mod t)) ;; List expirable messages and delete them from the data to be saved. - (setq ctime (when (numberp pop3-leave-mail-on-server) - (/ (+ (* (car ctime) 65536.0) (cadr ctime)) 86400)) - i (1- (length saved))) + (setq i (1- (length saved))) (while (> i 0) (if (member (setq uidl (nth (1- i) saved)) pop3-uidl) (progn (setq tstamp (nth i saved)) - (if (and ctime - (> (- ctime (/ (+ (* (car tstamp) 65536.0) (cadr tstamp)) - 86400)) - pop3-leave-mail-on-server)) + (if (and age-limit + (time-less-p age-limit (time-subtract ctime tstamp))) ;; Mails to delete. (progn (setq mod t) @@ -424,7 +415,7 @@ Return non-nil if it is necessary to update the local UIDL file." (push uidl new))) ;; Mails having been deleted in the server. (setq mod t)) - (decf i 2)) + (cl-decf i 2)) (cond (saved (setcdr saved new)) (srvr @@ -440,7 +431,7 @@ Return non-nil if it is necessary to update the local UIDL file." (while (> i 0) (when (member (nth (1- i) pop3-uidl) dele) (push i uidl)) - (decf i)) + (cl-decf i)) (when uidl (pop3-send-streaming-command process "DELE" uidl nil))) mod)) @@ -594,7 +585,7 @@ Return the response string if optional second argument is non-nil." (goto-char pop3-read-point) (if (looking-at "-ERR") (error "%s" (buffer-substring (point) (- match-end 2))) - (if (not (looking-at "+OK")) + (if (not (looking-at "\\+OK")) (progn (setq pop3-read-point match-end) nil) (setq pop3-read-point match-end) (if return @@ -620,16 +611,14 @@ Return the response string if optional second argument is non-nil." If NOW, use that time instead." (require 'parse-time) (let* ((now (or now (current-time))) - (zone (nth 8 (decode-time now))) - (sign "+")) + (zone (decoded-time-zone (decode-time now)))) (when (< zone 0) - (setq sign "-") (setq zone (- zone))) (concat (format-time-string "%d" now) ;; The month name of the %b spec is locale-specific. Pfff. (format " %s " - (capitalize (car (rassoc (nth 4 (decode-time now)) + (capitalize (car (rassoc (decoded-time-month (decode-time now)) parse-time-months)))) (format-time-string "%Y %H:%M:%S %z" now)))) @@ -695,14 +684,14 @@ If NOW, use that time instead." "Send USER information to POP3 server." (pop3-send-command process (format "USER %s" user)) (let ((response (pop3-read-response process t))) - (if (not (and response (string-match "+OK" response))) + (if (not (and response (string-match "\\+OK" response))) (error "USER %s not valid" user)))) (defun pop3-pass (process) "Send authentication information to the server." (pop3-send-command process (format "PASS %s" pop3-password)) (let ((response (pop3-read-response process t))) - (if (not (and response (string-match "+OK" response))) + (if (not (and response (string-match "\\+OK" response))) (pop3-quit process)))) (defun pop3-apop (process user) @@ -715,7 +704,7 @@ If NOW, use that time instead." (let ((hash (md5 (concat pop3-timestamp pass) nil nil 'binary))) (pop3-send-command process (format "APOP %s %s" user hash)) (let ((response (pop3-read-response process t))) - (if (not (and response (string-match "+OK" response))) + (if (not (and response (string-match "\\+OK" response))) (pop3-quit process))))) )) @@ -785,7 +774,7 @@ Otherwise, return the size of the message-id MSG" (pop3-send-command process (format "DELE %s" msg)) (pop3-read-response process)) -(defun pop3-noop (process msg) +(defun pop3-noop (process _msg) "No-operation." (pop3-send-command process "NOOP") (pop3-read-response process)) diff --git a/lisp/net/puny.el b/lisp/net/puny.el index bb1ef290f64..23c7af80619 100644 --- a/lisp/net/puny.el +++ b/lisp/net/puny.el @@ -27,6 +27,7 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) (require 'seq) (defun puny-encode-domain (domain) diff --git a/lisp/net/quickurl.el b/lisp/net/quickurl.el index db1ff0d3ae9..91e980e4f15 100644 --- a/lisp/net/quickurl.el +++ b/lisp/net/quickurl.el @@ -3,7 +3,6 @@ ;; Copyright (C) 1999-2019 Free Software Foundation, Inc. ;; Author: Dave Pearson <davep@davep.org> -;; Maintainer: Dave Pearson <davep@davep.org> ;; Created: 1999-05-28 ;; Keywords: hypermedia @@ -155,7 +154,7 @@ could be used here." (defconst quickurl-reread-hook-postfix " ;; Local Variables: -;; eval: (progn (require 'quickurl) (add-hook 'local-write-file-hooks (lambda () (quickurl-read) nil))) +;; eval: (progn (require 'quickurl) (add-hook 'write-file-functions (lambda () (quickurl-read) nil) nil t)) ;; End: " "Example `quickurl-postfix' text that adds a local variable to the @@ -504,15 +503,15 @@ TYPE dictates what will be inserted, options are: (with-current-buffer quickurl-list-last-buffer (insert (pcase type - (`url (funcall quickurl-format-function url)) - (`naked-url (quickurl-url-url url)) - (`with-lookup (format "%s <URL:%s>" + ('url (funcall quickurl-format-function url)) + ('naked-url (quickurl-url-url url)) + ('with-lookup (format "%s <URL:%s>" (quickurl-url-keyword url) (quickurl-url-url url))) - (`with-desc (format "%S <URL:%s>" + ('with-desc (format "%S <URL:%s>" (quickurl-url-description url) (quickurl-url-url url))) - (`lookup (quickurl-url-keyword url))))) + ('lookup (quickurl-url-keyword url))))) (error "No URL details on that line")) url)) diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index de524d9ef10..5722582ab6c 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -39,13 +39,14 @@ ;; Open a new irc connection with: ;; M-x irc RET -;;; Todo: - ;;; Code: (require 'cl-lib) (require 'ring) (require 'time-date) +(eval-when-compile (require 'subr-x)) + +(defconst rcirc-id-string (concat "rcirc on GNU Emacs " emacs-version)) (defgroup rcirc nil "Simple IRC client." @@ -119,35 +120,39 @@ display purposes. If absent, the real server name will be displayed instead." (:channels (repeat string)) (:encryption (choice (const tls) (const plain))) - (:server-alias string)))) - :group 'rcirc) + (:server-alias string))))) (defcustom rcirc-default-port 6667 "The default port to connect to." - :type 'integer - :group 'rcirc) + :type 'integer) (defcustom rcirc-default-nick (user-login-name) "Your nick." - :type 'string - :group 'rcirc) + :type 'string) (defcustom rcirc-default-user-name "user" "Your user name sent to the server when connecting." :version "24.1" ; changed default - :type 'string - :group 'rcirc) + :type 'string) (defcustom rcirc-default-full-name "unknown" "The full name sent to the server when connecting." :version "24.1" ; changed default - :type 'string - :group 'rcirc) + :type 'string) + +(defcustom rcirc-default-part-reason rcirc-id-string + "The default reason to send when parting from a channel. +Used when no reason is explicitly given." + :type 'string) + +(defcustom rcirc-default-quit-reason rcirc-id-string + "The default reason to send when quitting a server. +Used when no reason is explicitly given." + :type 'string) (defcustom rcirc-fill-flag t "Non-nil means line-wrap messages printed in channel buffers." - :type 'boolean - :group 'rcirc) + :type 'boolean) (defcustom rcirc-fill-column nil "Column beyond which automatic line-wrapping should happen. @@ -157,16 +162,21 @@ call it to compute the number of columns." :risky t ; can get funcalled :type '(choice (const :tag "Value of `fill-column'" nil) (integer :tag "Number of columns") - (function :tag "Function returning the number of columns")) - :group 'rcirc) + (function :tag "Function returning the number of columns"))) (defcustom rcirc-fill-prefix nil "Text to insert before filled lines. If nil, calculate the prefix dynamically to line up text underneath each nick." :type '(choice (const :tag "Dynamic" nil) - (string :tag "Prefix text")) - :group 'rcirc) + (string :tag "Prefix text"))) + +(defcustom rcirc-url-max-length nil + "Maximum number of characters in displayed URLs. +If nil, no maximum is applied." + :version "27.1" + :type '(choice (const :tag "No maximum" nil) + (integer :tag "Number of characters"))) (defvar rcirc-ignore-buffer-activity-flag nil "If non-nil, ignore activity in this buffer.") @@ -179,16 +189,12 @@ underneath each nick." (defcustom rcirc-omit-responses '("JOIN" "PART" "QUIT" "NICK") "Responses which will be hidden when `rcirc-omit-mode' is enabled." - :type '(repeat string) - :group 'rcirc) + :type '(repeat string)) (defvar rcirc-prompt-start-marker nil) (define-minor-mode rcirc-omit-mode "Toggle the hiding of \"uninteresting\" lines. -With a prefix argument ARG, enable Rcirc-Omit mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Uninteresting lines are those whose responses are listed in `rcirc-omit-responses'." @@ -206,32 +212,27 @@ Uninteresting lines are those whose responses are listed in (defcustom rcirc-time-format "%H:%M " "Describes how timestamps are printed. Used as the first arg to `format-time-string'." - :type 'string - :group 'rcirc) + :type 'string) (defcustom rcirc-input-ring-size 1024 "Size of input history ring." - :type 'integer - :group 'rcirc) + :type 'integer) (defcustom rcirc-read-only-flag t "Non-nil means make text in IRC buffers read-only." - :type 'boolean - :group 'rcirc) + :type 'boolean) (defcustom rcirc-buffer-maximum-lines nil "The maximum size in lines for rcirc buffers. Channel buffers are truncated from the top to be no greater than this number. If zero or nil, no truncating is done." :type '(choice (const :tag "No truncation" nil) - (integer :tag "Number of lines")) - :group 'rcirc) + (integer :tag "Number of lines"))) (defcustom rcirc-scroll-show-maximum-output t "If non-nil, scroll buffer to keep the point at the bottom of the window." - :type 'boolean - :group 'rcirc) + :type 'boolean) (defcustom rcirc-authinfo nil "List of authentication passwords. @@ -270,21 +271,18 @@ Examples: (list :tag "QuakeNet" (const quakenet) (string :tag "Account") - (string :tag "Password")))) - :group 'rcirc) + (string :tag "Password"))))) (defcustom rcirc-auto-authenticate-flag t "Non-nil means automatically send authentication string to server. See also `rcirc-authinfo'." - :type 'boolean - :group 'rcirc) + :type 'boolean) (defcustom rcirc-authenticate-before-join t "Non-nil means authenticate to services before joining channels. Currently only works with NickServ on some networks." :version "24.1" - :type 'boolean - :group 'rcirc) + :type 'boolean) (defcustom rcirc-prompt "> " "Prompt string to use in IRC buffers. @@ -298,19 +296,16 @@ 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 - :initialize 'custom-initialize-default - :group 'rcirc) + :initialize 'custom-initialize-default) (defcustom rcirc-keywords nil "List of keywords to highlight in message text." - :type '(repeat string) - :group 'rcirc) + :type '(repeat string)) (defcustom rcirc-ignore-list () "List of ignored nicks. Use /ignore to list them, use /ignore NICK to add or remove a nick." - :type '(repeat string) - :group 'rcirc) + :type '(repeat string)) (defvar rcirc-ignore-list-automatic () "List of ignored nicks added to `rcirc-ignore-list' because of renaming. @@ -321,42 +316,36 @@ parts.") (defcustom rcirc-bright-nicks nil "List of nicks to be emphasized. See `rcirc-bright-nick' face." - :type '(repeat string) - :group 'rcirc) + :type '(repeat string)) (defcustom rcirc-dim-nicks nil "List of nicks to be deemphasized. See `rcirc-dim-nick' face." - :type '(repeat string) - :group 'rcirc) + :type '(repeat string)) (define-obsolete-variable-alias 'rcirc-print-hooks 'rcirc-print-functions "24.3") (defcustom rcirc-print-functions nil "Hook run after text is printed. Called with 5 arguments, PROCESS, SENDER, RESPONSE, TARGET and TEXT." - :type 'hook - :group 'rcirc) + :type 'hook) (defvar rcirc-authenticated-hook nil "Hook run after successfully authenticated.") (defcustom rcirc-always-use-server-buffer-flag nil "Non-nil means messages without a channel target will go to the server buffer." - :type 'boolean - :group 'rcirc) + :type 'boolean) (defcustom rcirc-decode-coding-system 'utf-8 "Coding system used to decode incoming irc messages. Set to `undecided' if you want the encoding of the incoming messages autodetected." - :type 'coding-system - :group 'rcirc) + :type 'coding-system) (defcustom rcirc-encode-coding-system 'utf-8 "Coding system used to encode outgoing irc messages." - :type 'coding-system - :group 'rcirc) + :type 'coding-system) (defcustom rcirc-coding-system-alist nil "Alist to decide a coding system to use for a channel I/O operation. @@ -375,13 +364,11 @@ and the cdr part is used for encoding." (string :tag "Server Regexp"))) :value-type (choice coding-system (cons (coding-system :tag "Decode") - (coding-system :tag "Encode")))) - :group 'rcirc) + (coding-system :tag "Encode"))))) (defcustom rcirc-multiline-major-mode 'fundamental-mode "Major-mode function to use in multiline edit buffers." - :type 'function - :group 'rcirc) + :type 'function) (defcustom rcirc-nick-completion-format "%s: " "Format string to use in nick completions. @@ -390,16 +377,14 @@ The format string is only used when completing at the beginning of a line. The string is passed as the first argument to `format' with the nickname as the second argument." :version "24.1" - :type 'string - :group 'rcirc) + :type 'string) (defcustom rcirc-kill-channel-buffers nil "When non-nil, kill channel buffers when the server buffer is killed. Only the channel buffers associated with the server in question will be killed." :version "24.3" - :type 'boolean - :group 'rcirc) + :type 'boolean) (defvar rcirc-nick nil) @@ -441,7 +426,6 @@ will be killed." (defvar rcirc-timeout-seconds 600 "Kill connection after this many seconds if there is no activity.") -(defconst rcirc-id-string (concat "rcirc on GNU Emacs " emacs-version)) (defvar rcirc-startup-channels nil) @@ -637,13 +621,12 @@ If ARG is non-nil, instead prompt for connection parameters." (defun rcirc-prompt-for-encryption (server-plist) "Prompt the user for the encryption method to use. SERVER-PLIST is the property list for the server." - (let ((msg "Encryption (default %s): ") - (choices '("plain" "tls")) + (let ((choices '("plain" "tls")) (default (or (plist-get server-plist :encryption) - 'plain))) + "plain"))) (intern - (completing-read (format msg default) - choices nil t nil nil (symbol-name default))))) + (completing-read (format "Encryption (default %s): " default) + choices nil t nil nil default)))) (defun rcirc-keepalive () "Send keep alive pings to active rcirc processes. @@ -665,24 +648,33 @@ last ping." (defun rcirc-handler-ctcp-KEEPALIVE (process _target _sender message) (with-rcirc-process-buffer process - (setq header-line-format (format "%f" (- (float-time) - (string-to-number message)))))) + (setq header-line-format + (format "%f" (float-time + (time-since (string-to-number message))))))) (defvar rcirc-debug-buffer "*rcirc debug*") (defvar rcirc-debug-flag nil "If non-nil, write information to `rcirc-debug-buffer'.") (defun rcirc-debug (process text) "Add an entry to the debug log including PROCESS and TEXT. -Debug text is written to `rcirc-debug-buffer' if `rcirc-debug-flag' -is non-nil." +Debug text is appended to `rcirc-debug-buffer' if `rcirc-debug-flag' +is non-nil. + +For convenience, the read-only state of the debug buffer is ignored. +When the point is at the end of the visible portion of the buffer, it +is moved to after the text inserted. Otherwise the point is not moved." (when rcirc-debug-flag (with-current-buffer (get-buffer-create rcirc-debug-buffer) - (goto-char (point-max)) - (insert (concat - "[" - (format-time-string "%Y-%m-%dT%T ") (process-name process) - "] " - text))))) + (let ((old (point-marker))) + (set-marker-insertion-type old t) + (goto-char (point-max)) + (let ((inhibit-read-only t)) + (terpri (current-buffer) t) + (insert "[" + (format-time-string "%FT%T ") (process-name process) + "] " + text)) + (goto-char old))))) (define-obsolete-variable-alias 'rcirc-sentinel-hooks 'rcirc-sentinel-functions "24.3") @@ -694,8 +686,7 @@ Functions are called with PROCESS and SENTINEL arguments.") "The minimum interval in seconds between reconnect attempts. When 0, do not auto-reconnect." :version "25.1" - :type 'integer - :group 'rcirc) + :type 'integer) (defvar rcirc-last-connect-time nil "The last time the buffer was connected.") @@ -718,8 +709,8 @@ When 0, do not auto-reconnect." (< 0 rcirc-reconnect-delay)) (let ((now (current-time))) (when (or (null rcirc-last-connect-time) - (< rcirc-reconnect-delay - (float-time (time-subtract now rcirc-last-connect-time)))) + (time-less-p rcirc-reconnect-delay + (time-subtract now rcirc-last-connect-time))) (setq rcirc-last-connect-time now) (rcirc-cmd-reconnect nil)))) (run-hook-with-args 'rcirc-sentinel-functions process sentinel)))) @@ -784,22 +775,33 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.") (rcirc-process-server-response-1 process text))) (defun rcirc-process-server-response-1 (process text) - (if (string-match "^\\(:\\([^ ]+\\) \\)?\\([^ ]+\\) \\(.+\\)$" text) + ;; See https://tools.ietf.org/html/rfc2812#section-2.3.1. We're a + ;; bit more accepting than the RFC: We allow any non-space + ;; characters in the command name, multiple spaces between + ;; arguments, and allow the last argument to omit the leading ":", + ;; even if there are less than 15 arguments. + (if (string-match "^\\(:\\([^ ]+\\) \\)?\\([^ ]+\\)" text) (let* ((user (match-string 2 text)) (sender (rcirc-user-nick user)) (cmd (match-string 3 text)) - (args (match-string 4 text)) + (cmd-end (match-end 3)) + (args nil) (handler (intern-soft (concat "rcirc-handler-" cmd)))) - (string-match "^\\([^:]*\\):?\\(.+\\)?$" args) - (let* ((args1 (match-string 1 args)) - (args2 (match-string 2 args)) - (args (delq nil (append (split-string args1 " " t) - (list args2))))) + (cl-loop with i = cmd-end + repeat 14 + while (eql i (string-match " +\\([^: ][^ ]*\\)" text i)) + do (progn (push (match-string 1 text) args) + (setq i (match-end 0))) + finally + (progn (if (eql i (string-match " +:?" text i)) + (push (substring text (match-end 0)) args) + (cl-assert (= i (length text)))) + (cl-callf nreverse args))) (if (not (fboundp handler)) (rcirc-handler-generic process cmd sender args text) (funcall handler process sender args text)) (run-hook-with-args 'rcirc-receive-message-functions - process cmd sender args text))) + process cmd sender args text)) (message "UNHANDLED: %s" text))) (defvar rcirc-responses-no-activity '("305" "306") @@ -1162,14 +1164,12 @@ If ALL is non-nil, update prompts in all IRC buffers." (defcustom rcirc-log-directory "~/.emacs.d/rcirc-log" "Directory to keep IRC logfiles." - :type 'directory - :group 'rcirc) + :type 'directory) (defcustom rcirc-log-flag nil "Non-nil means log IRC activity to disk. Logfiles are kept in `rcirc-log-directory'." - :type 'boolean - :group 'rcirc) + :type 'boolean) (defun rcirc-kill-buffer-hook () "Part the channel when killing an rcirc buffer. @@ -1182,6 +1182,8 @@ with it." rcirc-log-directory) (rcirc-log-write)) (rcirc-clean-up-buffer "Killed buffer") + (when-let ((process (get-buffer-process (current-buffer)))) + (delete-process process)) (when (and rcirc-buffer-alist ;; it's a server buffer rcirc-kill-channel-buffers) (dolist (channel rcirc-buffer-alist) @@ -1353,15 +1355,11 @@ Create the buffer if it doesn't exist." "Keymap for multiline mode in rcirc.") (define-minor-mode rcirc-multiline-minor-mode - "Minor mode for editing multiple lines in rcirc. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "Minor mode for editing multiple lines in rcirc." :init-value nil :lighter " rcirc-mline" :keymap rcirc-multiline-minor-mode-map :global nil - :group 'rcirc (setq fill-column rcirc-max-message-length)) (defun rcirc-multiline-minor-submit () @@ -1423,8 +1421,7 @@ the of the following escape sequences replaced by the described values: %% A literal `%' character" :type '(alist :key-type (choice (string :tag "Type") (const :tag "Default" t)) - :value-type string) - :group 'rcirc) + :value-type string)) (defun rcirc-format-response-string (process sender response target text) "Return a nicely-formatted response string, incorporating TEXT @@ -1506,12 +1503,10 @@ is found by looking up RESPONSE in `rcirc-response-formats'." (defcustom rcirc-omit-threshold 100 "Number of lines since last activity from a nick before `rcirc-omit-responses' are omitted." - :type 'integer - :group 'rcirc) + :type 'integer) (defcustom rcirc-log-process-buffers nil "Non-nil if rcirc process buffers should be logged to disk." - :group 'rcirc :type 'boolean :version "24.1") @@ -1704,7 +1699,6 @@ is put into `rcirc-log-directory'. The filename is then cleaned using `convert-standard-filename' to guarantee valid filenames for the current OS." - :group 'rcirc :type 'function) (defun rcirc-log (process sender response target text) @@ -1867,15 +1861,11 @@ This function does not alter the INPUT string." ;;;###autoload (define-minor-mode rcirc-track-minor-mode - "Global minor mode for tracking activity in rcirc buffers. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "Global minor mode for tracking activity in rcirc buffers." :init-value nil :lighter "" :keymap rcirc-track-minor-mode-map :global t - :group 'rcirc (or global-mode-string (setq global-mode-string '(""))) ;; toggle the mode-line channel indicator (if rcirc-track-minor-mode @@ -2065,9 +2055,7 @@ activity. Only run if the buffer is not visible and (defvar rcirc-visible-buffers nil) (defun rcirc-window-configuration-change () (unless (minibuffer-window-active-p (minibuffer-window)) - ;; delay this until command has finished to make sure window is - ;; actually visible before clearing activity - (add-hook 'post-command-hook 'rcirc-window-configuration-change-1))) + (rcirc-window-configuration-change-1))) (defun rcirc-window-configuration-change-1 () ;; clear activity and overlay arrows @@ -2091,9 +2079,7 @@ activity. Only run if the buffer is not visible and rcirc-activity))) ;; update the mode-line string (unless (equal old-activity rcirc-activity) - (rcirc-update-activity-string))) - - (remove-hook 'post-command-hook 'rcirc-window-configuration-change-1)) + (rcirc-update-activity-string)))) ;;; buffer name abbreviation @@ -2223,12 +2209,21 @@ CHANNELS is a comma- or space-separated string of channel names." (read-string "Channel: ")))) (rcirc-send-string process (concat "INVITE " nick-channel))) -;; TODO: /part #channel reason, or consider removing #channel altogether (defun-rcirc-command part (channel) - "Part CHANNEL." + "Part CHANNEL. +CHANNEL should be a string of the form \"#CHANNEL-NAME REASON\". +If omitted, CHANNEL-NAME defaults to TARGET, and REASON defaults +to `rcirc-default-part-reason'." (interactive "sPart channel: ") - (let ((channel (if (> (length channel) 0) channel target))) - (rcirc-send-string process (concat "PART " channel " :" rcirc-id-string)))) + (let ((channel (if (> (length channel) 0) channel target)) + (msg rcirc-default-part-reason)) + (when (string-match "\\`\\([&#+!]\\S-+\\)?\\s-*\\(.+\\)?\\'" channel) + (when (match-beginning 2) + (setq msg (match-string 2 channel))) + (setq channel (if (match-beginning 1) + (match-string 1 channel) + target))) + (rcirc-send-string process (concat "PART " channel " :" msg)))) (defun-rcirc-command quit (reason) "Send a quit message to server with REASON." @@ -2236,7 +2231,7 @@ CHANNELS is a comma- or space-separated string of channel names." (rcirc-send-string process (concat "QUIT :" (if (not (zerop (length reason))) reason - rcirc-id-string)))) + rcirc-default-quit-reason)))) (defun-rcirc-command reconnect (_) "Reconnect to current server." @@ -2494,24 +2489,26 @@ If ARG is given, opens the URL in a new browser window." (rcirc-record-activity (current-buffer) 'nick))))) (defun rcirc-markup-urls (_sender _response) - (while (and rcirc-url-regexp ;; nil means disable URL catching + (while (and rcirc-url-regexp ; nil means disable URL catching. (re-search-forward rcirc-url-regexp nil t)) (let* ((start (match-beginning 0)) - (end (match-end 0)) - (url (match-string-no-properties 0)) - (link-text (buffer-substring-no-properties start end))) + (url (buffer-substring-no-properties start (point)))) + (when rcirc-url-max-length + ;; Replace match with truncated URL. + (delete-region start (point)) + (insert (url-truncate-url-for-viewing url rcirc-url-max-length))) ;; Add a button for the URL. Note that we use `make-text-button', ;; rather than `make-button', as text-buttons are much faster in ;; large buffers. - (make-text-button start end + (make-text-button start (point) 'face 'rcirc-url 'follow-link t 'rcirc-url url 'action (lambda (button) (browse-url (button-get button 'rcirc-url)))) - ;; record the url if it is not already the latest stored url - (when (not (string= link-text (caar rcirc-urls))) - (push (cons link-text start) rcirc-urls))))) + ;; Record the URL if it is not already the latest stored URL. + (unless (string= url (caar rcirc-urls)) + (push (cons url start) rcirc-urls))))) (defun rcirc-markup-keywords (sender response) (when (and (string= response "PRIVMSG") @@ -2561,16 +2558,15 @@ If ARG is given, opens the URL in a new browser window." (setq rcirc-server-name sender) (setq rcirc-nick (car args)) (rcirc-update-prompt) - (if rcirc-auto-authenticate-flag - (if (and rcirc-authenticate-before-join - ;; We have to ensure that there's an authentication - ;; entry for that server. Else, - ;; rcirc-authenticated-hook won't be triggered, and - ;; autojoin won't happen at all. - (let (auth-required) - (dolist (s rcirc-authinfo auth-required) - (when (string-match (car s) rcirc-server-name) - (setq auth-required t))))) + (if (and rcirc-auto-authenticate-flag + ;; We have to ensure that there's an authentication + ;; entry for that server. Otherwise, + ;; there's no point in calling authenticate. + (let (auth-required) + (dolist (s rcirc-authinfo auth-required) + (when (string-match (car s) rcirc-server) + (setq auth-required t))))) + (if rcirc-authenticate-before-join (progn (add-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t t) (rcirc-authenticate)) @@ -2796,11 +2792,8 @@ the only argument." "RPL_WHOISIDLE" (let* ((nick (nth 1 args)) (idle-secs (string-to-number (nth 2 args))) - (idle-string - (if (< idle-secs most-positive-fixnum) - (format-seconds "%yy %dd %hh %mm %z%ss" idle-secs) - "a very long time")) - (signon-time (seconds-to-time (string-to-number (nth 3 args)))) + (idle-string (format-seconds "%yy %dd %hh %mm %z%ss" idle-secs)) + (signon-time (string-to-number (nth 3 args))) (signon-string (format-time-string "%c" signon-time)) (message (format "%s idle for %s, signed on %s" nick idle-string signon-string))) @@ -2821,8 +2814,7 @@ Not in rfc1459.txt" (with-current-buffer buffer (let ((setter (nth 2 args)) (time (current-time-string - (seconds-to-time - (string-to-number (cl-cadddr args)))))) + (string-to-number (cl-cadddr args))))) (rcirc-print process sender "TOPIC" (cadr args) (format "%s (%s on %s)" rcirc-topic setter time)))))) @@ -2969,8 +2961,7 @@ Passwords are stored in `rcirc-authinfo' (which see)." (((class color) (min-colors 16) (background dark)) :foreground "LightSkyBlue") (((class color) (min-colors 8)) :foreground "blue" :weight bold) (t :inverse-video t :weight bold)) - "Rcirc face for my messages." - :group 'rcirc-faces) + "Rcirc face for my messages.") (defface rcirc-other-nick ; font-lock-variable-name-face '((((class grayscale) (background light)) @@ -2983,8 +2974,7 @@ Passwords are stored in `rcirc-authinfo' (which see)." (((class color) (min-colors 16) (background dark)) :foreground "LightGoldenrod") (((class color) (min-colors 8)) :foreground "yellow" :weight light) (t :weight bold :slant italic)) - "Rcirc face for other users' messages." - :group 'rcirc-faces) + "Rcirc face for other users' messages.") (defface rcirc-bright-nick '((((class grayscale) (background light)) @@ -2997,13 +2987,11 @@ Passwords are stored in `rcirc-authinfo' (which see)." (((class color) (min-colors 16) (background dark)) :foreground "Aquamarine") (((class color) (min-colors 8)) :foreground "magenta") (t :weight bold :underline t)) - "Rcirc face for nicks matched by `rcirc-bright-nicks'." - :group 'rcirc-faces) + "Rcirc face for nicks matched by `rcirc-bright-nicks'.") (defface rcirc-dim-nick '((t :inherit default)) - "Rcirc face for nicks in `rcirc-dim-nicks'." - :group 'rcirc-faces) + "Rcirc face for nicks in `rcirc-dim-nicks'.") (defface rcirc-server ; font-lock-comment-face '((((class grayscale) (background light)) @@ -3021,8 +3009,7 @@ Passwords are stored in `rcirc-authinfo' (which see)." (((class color) (min-colors 8) (background light))) (((class color) (min-colors 8) (background dark))) (t :weight bold :slant italic)) - "Rcirc face for server messages." - :group 'rcirc-faces) + "Rcirc face for server messages.") (defface rcirc-server-prefix ; font-lock-comment-delimiter-face '((default :inherit rcirc-server) @@ -3032,13 +3019,11 @@ Passwords are stored in `rcirc-authinfo' (which see)." :foreground "red") (((class color) (min-colors 8) (background dark)) :foreground "red1")) - "Rcirc face for server prefixes." - :group 'rcirc-faces) + "Rcirc face for server prefixes.") (defface rcirc-timestamp '((t :inherit default)) - "Rcirc face for timestamps." - :group 'rcirc-faces) + "Rcirc face for timestamps.") (defface rcirc-nick-in-message ; font-lock-keyword-face '((((class grayscale) (background light)) :foreground "LightGray" :weight bold) @@ -3049,37 +3034,30 @@ Passwords are stored in `rcirc-authinfo' (which see)." (((class color) (min-colors 16) (background dark)) :foreground "Cyan") (((class color) (min-colors 8)) :foreground "cyan" :weight bold) (t :weight bold)) - "Rcirc face for instances of your nick within messages." - :group 'rcirc-faces) + "Rcirc face for instances of your nick within messages.") (defface rcirc-nick-in-message-full-line '((t :weight bold)) - "Rcirc face for emphasizing the entire message when your nick is mentioned." - :group 'rcirc-faces) + "Rcirc face for emphasizing the entire message when your nick is mentioned.") (defface rcirc-prompt ; comint-highlight-prompt '((((min-colors 88) (background dark)) :foreground "cyan1") (((background dark)) :foreground "cyan") (t :foreground "dark blue")) - "Rcirc face for prompts." - :group 'rcirc-faces) + "Rcirc face for prompts.") (defface rcirc-track-nick '((((type tty)) :inherit default) (t :inverse-video t)) - "Rcirc face used in the mode-line when your nick is mentioned." - :group 'rcirc-faces) + "Rcirc face used in the mode-line when your nick is mentioned.") (defface rcirc-track-keyword '((t :weight bold)) - "Rcirc face used in the mode-line when keywords are mentioned." - :group 'rcirc-faces) + "Rcirc face used in the mode-line when keywords are mentioned.") (defface rcirc-url '((t :weight bold)) - "Rcirc face used to highlight urls." - :group 'rcirc-faces) + "Rcirc face used to highlight urls.") (defface rcirc-keyword '((t :inherit highlight)) - "Rcirc face used to highlight keywords." - :group 'rcirc-faces) + "Rcirc face used to highlight keywords.") ;; When using M-x flyspell-mode, only check words after the prompt diff --git a/lisp/net/rfc2104.el b/lisp/net/rfc2104.el index 3b000399b99..5de8401d5b6 100644 --- a/lisp/net/rfc2104.el +++ b/lisp/net/rfc2104.el @@ -1,4 +1,4 @@ -;;; rfc2104.el --- RFC2104 Hashed Message Authentication Codes +;;; rfc2104.el --- RFC2104 Hashed Message Authentication Codes -*- lexical-binding:t -*- ;; Copyright (C) 1998-2019 Free Software Foundation, Inc. @@ -55,7 +55,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; Magic character for inner HMAC round. 0x36 == 54 == '6' (defconst rfc2104-ipad ?\x36) @@ -84,14 +84,6 @@ (setq ls (cdr ls))) v)) -(eval-when-compile - (defmacro rfc2104-string-make-unibyte (string) - "Return the unibyte equivalent of STRING. -In XEmacs return just STRING." - (if (featurep 'xemacs) - string - `(string-make-unibyte ,string)))) - (defun rfc2104-hash (hash block-length hash-length key text) (let* (;; if key is longer than B, reset it to HASH(key) (key (if (> (length key) block-length) @@ -101,23 +93,22 @@ In XEmacs return just STRING." (opad (make-string (+ block-length hash-length) rfc2104-opad)) c partial) ;; Prefix *pad with key, appropriately XORed. - (do ((i 0 (1+ i))) + (cl-do ((i 0 (1+ i))) ((= len i)) (setq c (aref key i)) (aset ipad i (logxor rfc2104-ipad c)) (aset opad i (logxor rfc2104-opad c))) ;; Perform inner hash. - (setq partial (rfc2104-string-make-unibyte - (funcall hash (concat ipad text)))) + (setq partial (funcall hash (concat ipad text))) ;; Pack latter part of opad. - (do ((r 0 (+ 2 r)) - (w block-length (1+ w))) + (cl-do ((r 0 (+ 2 r)) + (w block-length (1+ w))) ((= (* 2 hash-length) r)) (aset opad w (+ (* 16 (aref rfc2104-nybbles (aref partial r))) ( aref rfc2104-nybbles (aref partial (1+ r)))))) ;; Perform outer hash. - (rfc2104-string-make-unibyte (funcall hash opad)))) + (funcall hash opad))) (provide 'rfc2104) diff --git a/lisp/net/rlogin.el b/lisp/net/rlogin.el index f73638699d4..9da35488361 100644 --- a/lisp/net/rlogin.el +++ b/lisp/net/rlogin.el @@ -1,10 +1,9 @@ -;;; rlogin.el --- remote login interface +;;; rlogin.el --- remote login interface -*- lexical-binding:t -*- ;; Copyright (C) 1992-1995, 1997-1998, 2001-2019 Free Software ;; Foundation, Inc. -;; Author: Noah Friedman -;; Maintainer: Noah Friedman <friedman@splode.com> +;; Author: Noah Friedman <friedman@splode.com> ;; Keywords: unix, comm ;; This file is part of GNU Emacs. @@ -30,9 +29,9 @@ ;; tracking and the sending of some special characters. ;; If you wish for rlogin mode to prompt you in the minibuffer for -;; passwords when a password prompt appears, just enter m-x send-invisible -;; and type in your line, or add `comint-watch-for-password-prompt' to -;; `comint-output-filter-functions'. +;; passwords when a password prompt appears, just enter +;; M-x comint-send-invisible and type in your line (or tweak +;; `comint-password-prompt-regexp' to match your password prompt). ;;; Code: diff --git a/lisp/net/sasl-cram.el b/lisp/net/sasl-cram.el index a4d80c92e53..cbca829b035 100644 --- a/lisp/net/sasl-cram.el +++ b/lisp/net/sasl-cram.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2000, 2007-2019 Free Software Foundation, Inc. -;; Author: Daiki Ueno <ueno@unixuser.org> +;; Author: Daiki Ueno <ueno@gnu.org> ;; Kenichi OKADA <okada@opaopa.org> ;; Keywords: SASL, CRAM-MD5 ;; Package: sasl diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el index e67a5a915fa..bd0351644a8 100644 --- a/lisp/net/sasl.el +++ b/lisp/net/sasl.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2000, 2007-2019 Free Software Foundation, Inc. -;; Author: Daiki Ueno <ueno@unixuser.org> +;; Author: Daiki Ueno <ueno@gnu.org> ;; Keywords: SASL ;; This file is part of GNU Emacs. @@ -183,7 +183,7 @@ It contain at least 64 bits of entropy." ;; Don't use microseconds from (current-time), they may be unsupported. ;; Instead we use this randomly inited counter. (setq sasl-unique-id-char - (% (1+ (or sasl-unique-id-char (logand (random) (1- (lsh 1 20))))) + (% (1+ (or sasl-unique-id-char (logand (random) (1- (ash 1 20))))) ;; (current-time) returns 16-bit ints, ;; and 2^16*25 just fits into 4 digits i base 36. (* 25 25))) @@ -191,10 +191,10 @@ It contain at least 64 bits of entropy." (concat (sasl-unique-id-number-base36 (+ (car tm) - (lsh (% sasl-unique-id-char 25) 16)) 4) + (ash (% sasl-unique-id-char 25) 16)) 4) (sasl-unique-id-number-base36 (+ (nth 1 tm) - (lsh (/ sasl-unique-id-char 25) 16)) 4)))) + (ash (/ sasl-unique-id-char 25) 16)) 4)))) (defun sasl-unique-id-number-base36 (num len) (if (if (< len 0) diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el index e8d2091296a..5d294ce2c51 100644 --- a/lisp/net/secrets.el +++ b/lisp/net/secrets.el @@ -158,7 +158,7 @@ (defvar secrets-enabled nil "Whether there is a daemon offering the Secret Service API.") -(defvar secrets-debug t +(defvar secrets-debug nil "Write debug messages") (defconst secrets-service "org.freedesktop.secrets" @@ -331,9 +331,7 @@ It returns t if not." ;; Properties. `(:array (:dict-entry ,(concat secrets-interface-item ".Label") - (:variant "dummy")) - (:dict-entry ,(concat secrets-interface-item ".Type") - (:variant ,secrets-interface-item-type-generic))) + (:variant " "))) ;; Secret. `(:struct :object-path ,path (:array :signature "y") @@ -539,6 +537,18 @@ For the time being, only the alias \"default\" is supported." secrets-interface-service "SetAlias" alias :object-path secrets-empty-path)) +(defun secrets-lock-collection (collection) + "Lock collection labeled COLLECTION. +If successful, return the object path of the collection." + (let ((collection-path (secrets-collection-path collection))) + (unless (secrets-empty-path collection-path) + (secrets-prompt + (cadr + (dbus-call-method + :session secrets-service secrets-path secrets-interface-service + "Lock" `(:array :object-path ,collection-path))))) + collection-path)) + (defun secrets-unlock-collection (collection) "Unlock collection labeled COLLECTION. If successful, return the object path of the collection." @@ -565,7 +575,6 @@ If successful, return the object path of the collection." (defun secrets-get-items (collection-path) "Return the object paths of all available items in COLLECTION-PATH." (unless (secrets-empty-path collection-path) - (secrets-open-session) (dbus-get-property :session secrets-service collection-path secrets-interface-collection "Items"))) @@ -593,16 +602,16 @@ If successful, return the object path of the collection." (secrets-get-item-property item-path "Label")) (secrets-get-items collection-path))))) -(defun secrets-search-items (collection &rest attributes) +(defun secrets-search-item-paths (collection &rest attributes) "Search items in COLLECTION with ATTRIBUTES. ATTRIBUTES are key-value pairs. The keys are keyword symbols, starting with a colon. Example: - (secrets-search-items \"Tramp collection\" :user \"joe\") + (secrets-search-item-paths \"Tramp collection\" :user \"joe\") -The object labels of the found items are returned as list." +The object paths of the found items are returned as list." (let ((collection-path (secrets-unlock-collection collection)) - result props) + props) (unless (secrets-empty-path collection-path) ;; Create attributes list. (while (consp (cdr attributes)) @@ -617,84 +626,109 @@ The object labels of the found items are returned as list." ,(cadr attributes)))) attributes (cddr attributes))) ;; Search. The result is a list of object paths. - (setq result - (dbus-call-method - :session secrets-service collection-path - secrets-interface-collection "SearchItems" - (if props - (cons :array props) - '(:array :signature "{ss}")))) - ;; Return the found items. - (mapcar - (lambda (item-path) (secrets-get-item-property item-path "Label")) - result)))) + (dbus-call-method + :session secrets-service collection-path + secrets-interface-collection "SearchItems" + (if props + (cons :array props) + '(:array :signature "{ss}")))))) + +(defun secrets-search-items (collection &rest attributes) + "Search items in COLLECTION with ATTRIBUTES. +ATTRIBUTES are key-value pairs. The keys are keyword symbols, +starting with a colon. Example: + + (secrets-search-items \"Tramp collection\" :user \"joe\") + +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))) (defun secrets-create-item (collection item password &rest attributes) "Create a new item in COLLECTION with label ITEM and password PASSWORD. +The label ITEM does not have to be unique in COLLECTION. ATTRIBUTES are key-value pairs set for the created item. The keys are keyword symbols, starting with a colon. Example: (secrets-create-item \"Tramp collection\" \"item\" \"geheim\" :method \"sudo\" :user \"joe\" :host \"remote-host\") +The key `:xdg:schema' determines the scope of the item to be +generated, i.e. for which applications the item is intended for. +This is just a string like \"org.freedesktop.NetworkManager.Mobile\" +or \"org.gnome.OnlineAccounts\", the other required keys are +determined by this. If no `:xdg:schema' is given, +\"org.freedesktop.Secret.Generic\" is used by default. + The object path of the created item is returned." - (unless (member item (secrets-list-items collection)) - (let ((collection-path (secrets-unlock-collection collection)) - result props) - (unless (secrets-empty-path collection-path) - ;; Create attributes list. - (while (consp (cdr attributes)) - (unless (keywordp (car attributes)) - (error 'wrong-type-argument (car attributes))) - (unless (stringp (cadr attributes)) - (error 'wrong-type-argument (cadr attributes))) - (setq props (append - props - `((:dict-entry - ,(substring (symbol-name (car attributes)) 1) - ,(cadr attributes)))) - attributes (cddr attributes))) - ;; Create the item. - (setq result - (dbus-call-method - :session secrets-service collection-path - secrets-interface-collection "CreateItem" - ;; Properties. - (append - `(:array - (:dict-entry ,(concat secrets-interface-item ".Label") - (:variant ,item)) - (:dict-entry ,(concat secrets-interface-item ".Type") - (:variant ,secrets-interface-item-type-generic))) - (when props - `((:dict-entry ,(concat secrets-interface-item ".Attributes") - (:variant ,(append '(:array) props)))))) - ;; Secret. - (append - `(:struct :object-path ,secrets-session-path - (:array :signature "y") ;; No parameters. - ,(dbus-string-to-byte-array password)) - ;; We add the content_type. In backward compatibility - ;; mode, nil is appended, which means nothing. - secrets-struct-secret-content-type) - ;; Do not replace. Replace does not seem to work. - nil)) - (secrets-prompt (cadr result)) - ;; Return the object path. - (car result))))) + (let ((collection-path (secrets-unlock-collection collection)) + result props) + (unless (secrets-empty-path collection-path) + ;; Set default type if needed. + (unless (member :xdg:schema attributes) + (setq attributes + (append + attributes `(:xdg:schema ,secrets-interface-item-type-generic)))) + ;; Create attributes list. + (while (consp (cdr attributes)) + (unless (keywordp (car attributes)) + (error 'wrong-type-argument (car attributes))) + (unless (stringp (cadr attributes)) + (error 'wrong-type-argument (cadr attributes))) + (setq props (append + props + `((:dict-entry + ,(substring (symbol-name (car attributes)) 1) + ,(cadr attributes)))) + attributes (cddr attributes))) + ;; Create the item. + (setq result + (dbus-call-method + :session secrets-service collection-path + secrets-interface-collection "CreateItem" + ;; Properties. + (append + `(:array + (:dict-entry ,(concat secrets-interface-item ".Label") + (:variant ,item))) + (when props + `((:dict-entry ,(concat secrets-interface-item ".Attributes") + (:variant ,(append '(:array) props)))))) + ;; Secret. + (append + `(:struct :object-path ,secrets-session-path + (:array :signature "y") ;; No parameters. + ,(dbus-string-to-byte-array password)) + ;; We add the content_type. In backward compatibility + ;; mode, nil is appended, which means nothing. + secrets-struct-secret-content-type) + ;; Do not replace. Replace does not seem to work. + nil)) + (secrets-prompt (cadr result)) + ;; Return the object path. + (car result)))) (defun secrets-item-path (collection item) "Return the object path of item labeled ITEM in COLLECTION. -If there is no such item, return nil." +If there are several items labeled ITEM, it is undefined which +one is returned. If there is no such item, return nil. + +ITEM can also be an object path, which is returned if contained in COLLECTION." (let ((collection-path (secrets-unlock-collection collection))) - (catch 'item-found - (dolist (item-path (secrets-get-items collection-path)) - (when (string-equal item (secrets-get-item-property item-path "Label")) - (throw 'item-found item-path)))))) + (or (and (member item (secrets-get-items collection-path)) item) + (catch 'item-found + (dolist (item-path (secrets-get-items collection-path)) + (when (string-equal + item (secrets-get-item-property item-path "Label")) + (throw 'item-found item-path))))))) (defun secrets-get-secret (collection item) "Return the secret of item labeled ITEM in COLLECTION. -If there is no such item, return nil." +If there are several items labeled ITEM, it is undefined which +one is returned. If there is no such item, return nil. + +ITEM can also be an object path, which is used if contained in COLLECTION." (let ((item-path (secrets-item-path collection item))) (unless (secrets-empty-path item-path) (dbus-byte-array-to-string @@ -705,8 +739,11 @@ If there is no such item, return nil." (defun secrets-get-attributes (collection item) "Return the lookup attributes of item labeled ITEM in COLLECTION. -If there is no such item, or the item has no attributes, return nil." - (unless (stringp collection) (setq collection "default")) +If there are several items labeled ITEM, it is undefined which +one is returned. If there is no such item, or the item has no +attributes, return nil. + +ITEM can also be an object path, which is used if contained in COLLECTION." (let ((item-path (secrets-item-path collection item))) (unless (secrets-empty-path item-path) (mapcar @@ -718,11 +755,19 @@ If there is no such item, or the item has no attributes, return nil." (defun secrets-get-attribute (collection item attribute) "Return the value of ATTRIBUTE of item labeled ITEM in COLLECTION. -If there is no such item, or the item doesn't own this attribute, return nil." +If there are several items labeled ITEM, it is undefined which +one is returned. If there is no such item, or the item doesn't +own this attribute, return nil. + +ITEM can also be an object path, which is used if contained in COLLECTION." (cdr (assoc attribute (secrets-get-attributes collection item)))) (defun secrets-delete-item (collection item) - "Delete ITEM in COLLECTION." + "Delete item labeled ITEM in COLLECTION. +If there are several items labeled ITEM, it is undefined which +one is deleted. + +ITEM can also be an object path, which is used if contained in COLLECTION." (let ((item-path (secrets-item-path collection item))) (unless (secrets-empty-path item-path) (secrets-prompt @@ -872,6 +917,8 @@ to their attributes." (when (dbus-ping :session secrets-service 100) + (secrets-open-session) + ;; We must reset all variables, when there is a new instance of the ;; "org.freedesktop.secrets" service. (dbus-register-signal diff --git a/lisp/net/shr-color.el b/lisp/net/shr-color.el index fcc307b929c..af0b99c76f4 100644 --- a/lisp/net/shr-color.el +++ b/lisp/net/shr-color.el @@ -1,4 +1,4 @@ -;;; shr-color.el --- Simple HTML Renderer color management +;;; shr-color.el --- Simple HTML Renderer color management -*- lexical-binding:t -*- ;; Copyright (C) 2010-2019 Free Software Foundation, Inc. @@ -27,7 +27,7 @@ ;;; Code: (require 'color) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup shr-color nil "Simple HTML Renderer colors" @@ -210,8 +210,8 @@ This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"." (defun shr-color-hue-to-rgb (x y h) "Convert X Y H to RGB value." - (when (< h 0) (incf h)) - (when (> h 1) (decf h)) + (when (< h 0) (cl-incf h)) + (when (> h 1) (cl-decf h)) (cond ((< h (/ 6.0)) (+ x (* (- y x) h 6))) ((< h 0.5) y) ((< h (/ 2.0 3.0)) (+ x (* (- y x) (- (/ 2.0 3.0) h) 6))) @@ -235,7 +235,7 @@ Like rgb() or hsl()." (cond ;; Hexadecimal color: #abc or #aabbcc ((string-match - "\\(#[0-9a-fA-F]\\{3\\}[0-9a-fA-F]\\{3\\}?\\)" + "\\(#[[:xdigit:]]\\{3\\}[[:xdigit:]]\\{3\\}?\\)" color) (match-string 1 color)) ;; rgb() or rgba() colors @@ -259,8 +259,7 @@ Like rgb() or hsl()." (let ((h (/ (string-to-number (match-string-no-properties 1 color)) 360.0)) (s (/ (string-to-number (match-string-no-properties 2 color)) 100.0)) (l (/ (string-to-number (match-string-no-properties 3 color)) 100.0))) - (destructuring-bind (r g b) - (shr-color-hsl-to-rgb-fractions h s l) + (pcase-let ((`(,r ,g ,b) (shr-color-hsl-to-rgb-fractions h s l))) (color-rgb-to-hex r g b 2)))) ;; Color names ((cdr (assoc-string color shr-color-html-colors-alist t))) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 4e584e131fa..fbd1a9b7661 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -30,7 +30,7 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) (eval-when-compile (require 'url)) ;For url-filename's setf handler. (require 'browse-url) (eval-when-compile (require 'subr-x)) @@ -38,6 +38,8 @@ (require 'seq) (require 'svg) (require 'image) +(require 'puny) +(require 'text-property-search) (defgroup shr nil "Simple HTML Renderer" @@ -51,46 +53,44 @@ width and height of the window. If they are larger than this, and Emacs supports it, then the images will be rescaled down to fit these criteria." :version "24.1" - :group 'shr :type 'float) (defcustom shr-blocked-images nil "Images that have URLs matching this regexp will be blocked." :version "24.1" - :group 'shr :type '(choice (const nil) regexp)) (defcustom shr-use-fonts t "If non-nil, use proportional fonts for text." :version "25.1" - :group 'shr + :type 'boolean) + +(defcustom shr-discard-aria-hidden nil + "If non-nil, don't render tags with `aria-hidden=\"true\"'. +This attribute is meant to tell screen readers to ignore a tag." + :version "27.1" :type 'boolean) (defcustom shr-use-colors t "If non-nil, respect color specifications in the HTML." :version "26.1" - :group 'shr :type 'boolean) (defcustom shr-table-horizontal-line nil "Character used to draw horizontal table lines. If nil, don't draw horizontal table lines." - :group 'shr :type '(choice (const nil) character)) (defcustom shr-table-vertical-line ?\s "Character used to draw vertical table lines." - :group 'shr :type 'character) (defcustom shr-table-corner ?\s "Character used to draw table corners." - :group 'shr :type 'character) (defcustom shr-hr-line ?- "Character used to draw hr lines." - :group 'shr :type 'character) (defcustom shr-width nil @@ -101,8 +101,7 @@ If `shr-use-fonts' is set, the mean character width is used to compute the pixel width, which is used instead." :version "25.1" :type '(choice (integer :tag "Fixed width in characters") - (const :tag "Use the width of the window" nil)) - :group 'shr) + (const :tag "Use the width of the window" nil))) (defcustom shr-bullet "* " "Bullet used for unordered lists. @@ -110,19 +109,14 @@ Alternative suggestions are: - \" \" - \" \"" :version "24.4" - :type 'string - :group 'shr) + :type 'string) -(defcustom shr-external-browser 'browse-url-default-browser - "Function used to launch an external browser." - :version "24.4" - :group 'shr - :type 'function) +(define-obsolete-variable-alias 'shr-external-browser + 'browse-url-secondary-browser-function "27.1") (defcustom shr-image-animate t "Non nil means that images that can be animated will be." :version "24.4" - :group 'shr :type 'boolean) (defvar shr-content-function nil @@ -133,14 +127,26 @@ cid: URL as the argument.") (defvar shr-put-image-function 'shr-put-image "Function called to put image and alt string.") -(defface shr-strike-through '((t (:strike-through t))) - "Font for <s> elements." - :group 'shr) +(defface shr-strike-through '((t :strike-through t)) + "Face for <s> elements." + :version "24.1") (defface shr-link - '((t (:inherit link))) - "Font for link elements." - :group 'shr) + '((t :inherit link)) + "Face for link elements." + :version "24.1") + +(defface shr-selected-link + '((t :inherit shr-link :background "red")) + "Temporary face for externally visited link elements. +When a link is visited with an external browser, the link +temporarily blinks with this face." + :version "27.1") + +(defface shr-abbreviation + '((t :inherit underline :underline (:style wave))) + "Face for <abbr> elements." + :version "27.1") (defvar shr-inhibit-images nil "If non-nil, inhibit loading images.") @@ -267,7 +273,9 @@ DOM should be a parse tree as generated by (if (and (null shr-width) (not (shr--have-one-fringe-p))) (* (frame-char-width) 2) - 0))))) + 0) + 1)))) + (max-specpdl-size max-specpdl-size) bidi-display-reordering) ;; If the window was hscrolled for some reason, shr-fill-lines ;; below will misbehave, because it silently assumes that it @@ -344,52 +352,45 @@ If the URL is already at the front of the kill ring act like (shr-probe-and-copy-url url) (shr-copy-url url))) +(defun shr--current-link-region () + (let ((current (get-text-property (point) 'shr-url)) + start) + (save-excursion + ;; Go to the beginning. + (while (and (not (bobp)) + (equal (get-text-property (point) 'shr-url) current)) + (forward-char -1)) + (unless (equal (get-text-property (point) 'shr-url) current) + (forward-char 1)) + (setq start (point)) + ;; Go to the end. + (while (and (not (eobp)) + (equal (get-text-property (point) 'shr-url) current)) + (forward-char 1)) + (list start (point))))) + +(defun shr--blink-link () + (let* ((region (shr--current-link-region)) + (overlay (make-overlay (car region) (cadr region)))) + (overlay-put overlay 'face 'shr-selected-link) + (run-at-time 1 nil (lambda () + (delete-overlay overlay))))) + (defun shr-next-link () "Skip to the next link." (interactive) - (let ((current (get-text-property (point) 'shr-url)) - (start (point)) - skip) - (while (and (not (eobp)) - (equal (get-text-property (point) 'shr-url) current)) - (forward-char 1)) - (cond - ((and (not (eobp)) - (get-text-property (point) 'shr-url)) - ;; The next link is adjacent. - (message "%s" (get-text-property (point) 'help-echo))) - ((or (eobp) - (not (setq skip (text-property-not-all (point) (point-max) - 'shr-url nil)))) - (goto-char start) - (message "No next link")) - (t - (goto-char skip) - (message "%s" (get-text-property (point) 'help-echo)))))) + (let ((match (text-property-search-forward 'shr-url nil nil t))) + (if (not match) + (message "No next link") + (goto-char (prop-match-beginning match)) + (message "%s" (get-text-property (point) 'help-echo))))) (defun shr-previous-link () "Skip to the previous link." (interactive) - (let ((start (point)) - (found nil)) - ;; Skip past the current link. - (while (and (not (bobp)) - (get-text-property (point) 'help-echo)) - (forward-char -1)) - ;; Find the previous link. - (while (and (not (bobp)) - (not (setq found (get-text-property (point) 'help-echo)))) - (forward-char -1)) - (if (not found) - (progn - (message "No previous link") - (goto-char start)) - ;; Put point at the start of the link. - (while (and (not (bobp)) - (get-text-property (point) 'help-echo)) - (forward-char -1)) - (forward-char 1) - (message "%s" (get-text-property (point) 'help-echo))))) + (if (not (text-property-search-backward 'shr-url nil nil t)) + (message "No previous link") + (message "%s" (get-text-property (point) 'help-echo)))) (defun shr-show-alt-text () "Show the ALT text of the image under point." @@ -493,15 +494,20 @@ size, and full-buffer size." (shr-depth (1+ shr-depth)) (start (point))) ;; shr uses many frames per nested node. - (if (> shr-depth (/ max-specpdl-size 15)) - (setq shr-warning "Too deeply nested to render properly; consider increasing `max-specpdl-size'") + (if (and (> shr-depth (/ max-specpdl-size 15)) + (not (and (y-or-n-p "Too deeply nested to render properly; increase `max-specpdl-size'?") + (setq max-specpdl-size (* max-specpdl-size 2))))) + (setq shr-warning + "Not rendering the complete page because of too-deep nesting") (when style (if (string-match "color\\|display\\|border-collapse" style) (setq shr-stylesheet (nconc (shr-parse-style style) shr-stylesheet)) (setq style nil))) ;; If we have a display:none, then just ignore this part of the DOM. - (unless (equal (cdr (assq 'display shr-stylesheet)) "none") + (unless (or (equal (cdr (assq 'display shr-stylesheet)) "none") + (and shr-discard-aria-hidden + (equal (dom-attr dom 'aria-hidden) "true"))) ;; We don't use shr-indirect-call here, since shr-descend is ;; the central bit of shr.el, and should be as fast as ;; possible. Having one more level of indirection with its @@ -689,37 +695,49 @@ size, and full-buffer size." `,(shr-face-background face)))) (setq start (point)) (setq shr-indentation (or continuation shr-indentation)) - (shr-vertical-motion shr-internal-width) - (when (looking-at " $") - (delete-region (point) (line-end-position))) - (while (not (eolp)) - ;; We have to do some folding. First find the first - ;; previous point suitable for folding. - (if (or (not (shr-find-fill-point (line-beginning-position))) - (= (point) start)) - ;; We had unbreakable text (for this width), so just go to - ;; the first space and carry on. - (progn - (beginning-of-line) - (skip-chars-forward " ") - (search-forward " " (line-end-position) 'move))) - ;; Success; continue. - (when (= (preceding-char) ?\s) - (delete-char -1)) - (let ((props `(face ,(get-text-property (point) 'face) - ;; Don't break the image-displayer property - ;; as it will cause `gnus-article-show-images' - ;; to show the two or more same images. - image-displayer - ,(get-text-property (point) 'image-displayer))) - (gap-start (point))) - (insert "\n") - (shr-indent) - (add-text-properties gap-start (point) props)) - (setq start (point)) + ;; If we have an indentation that's wider than the width we're + ;; trying to fill to, then just give up and don't do any filling. + (when (< shr-indentation shr-internal-width) (shr-vertical-motion shr-internal-width) (when (looking-at " $") - (delete-region (point) (line-end-position)))))) + (delete-region (point) (line-end-position))) + (while (not (eolp)) + ;; We have to do some folding. First find the first + ;; previous point suitable for folding. + (if (or (not (shr-find-fill-point (line-beginning-position))) + (= (point) start)) + ;; We had unbreakable text (for this width), so just go to + ;; the first space and carry on. + (progn + (beginning-of-line) + (skip-chars-forward " ") + (search-forward " " (line-end-position) 'move))) + ;; Success; continue. + (when (= (preceding-char) ?\s) + (delete-char -1)) + (let ((gap-start (point))) + (insert "\n") + (shr-indent) + (when (and (> (1- gap-start) (point-min)) + ;; The link on both sides of the newline are the + ;; same... + (equal (get-text-property (point) 'shr-url) + (get-text-property (1- gap-start) 'shr-url))) + ;; ... so we join the two bits into one link logically, but + ;; not visually. This makes navigation between links work + ;; well, but avoids underscores before the link on the next + ;; line when indented. + (let* ((props (copy-sequence (text-properties-at (point)))) + (face (plist-get props 'face))) + ;; We don't want to use the faces on the indentation, because + ;; that's ugly, but we do want to use the background colour. + (when face + (setq props (plist-put props 'face (shr-face-background face)))) + (add-text-properties gap-start (point) props)))) + (setq start (point)) + (shr-vertical-motion shr-internal-width) + (when (looking-at " $") + (delete-region (point) (line-end-position))))))) (defun shr-find-fill-point (start) (let ((bp (point)) @@ -936,7 +954,7 @@ size, and full-buffer size." (defun shr-browse-url (&optional external mouse-event) "Browse the URL at point using `browse-url'. If EXTERNAL is non-nil (interactively, the prefix argument), browse -the URL using `shr-external-browser'. +the URL using `browse-url-secondary-browser-function'. If this function is invoked by a mouse click, it will browse the URL at the position of the click. Optional argument MOUSE-EVENT describes the mouse click event." @@ -950,7 +968,9 @@ the mouse click event." (browse-url-mail url)) (t (if external - (funcall shr-external-browser url) + (progn + (funcall browse-url-secondary-browser-function url) + (shr--blink-link)) (browse-url url)))))) (defun shr-save-contents (directory) @@ -1064,6 +1084,16 @@ element is the data blob and the second element is the content-type." image) (insert (or alt "")))) +(defun shr--image-type () + "Emacs image type to use when displaying images. +If Emacs has native image scaling support, that's used, but if +not, `imagemagick' is preferred if it's present." + (if (or (and (fboundp 'image-transforms-p) + (image-transforms-p)) + (not (fboundp 'imagemagick-types))) + nil + 'imagemagick)) + (defun shr-rescale-image (data content-type width height &optional max-width max-height) "Rescale DATA, if too big, to fit the current buffer. @@ -1072,8 +1102,7 @@ WIDTH and HEIGHT are the sizes given in the HTML data, if any. The size of the displayed image will not exceed MAX-WIDTH/MAX-HEIGHT. If not given, use the current window width/height instead." - (if (or (not (fboundp 'imagemagick-types)) - (not (get-buffer-window (current-buffer)))) + (if (not (get-buffer-window (current-buffer))) (create-image data nil t :ascent 100) (let* ((edges (window-inside-pixel-edges (get-buffer-window (current-buffer)))) @@ -1094,13 +1123,13 @@ width/height instead." (< (* width scaling) max-width) (< (* height scaling) max-height)) (create-image - data 'imagemagick t + data (shr--image-type) t :ascent 100 :width width :height height :format content-type) (create-image - data 'imagemagick t + data (shr--image-type) t :ascent 100 :max-width max-width :max-height max-height @@ -1178,12 +1207,26 @@ START, and END. Note that START and END should be markers." (add-text-properties start (point) (list 'shr-url url - 'help-echo (let ((iri (or (ignore-errors - (decode-coding-string - (url-unhex-string url) - 'utf-8 t)) - url))) - (if title (format "%s (%s)" iri title) iri)) + 'button t + 'category 'shr ; For button.el button buffers. + 'help-echo (let ((parsed (url-generic-parse-url + (or (ignore-errors + (decode-coding-string + (url-unhex-string url) + 'utf-8 t)) + url))) + iri) + ;; If we have an IDNA domain, then show the + ;; decoded version in the mouseover to let the + ;; user know that there's something possibly + ;; fishy. + (when (url-host parsed) + (setf (url-host parsed) + (puny-encode-domain (url-host parsed)))) + (setq iri (url-recreate-url parsed)) + (if title + (format "%s (%s)" iri title) + iri)) 'follow-link t 'mouse-face 'highlight)) ;; Don't overwrite any keymaps that are already in the buffer (i.e., @@ -1319,19 +1362,19 @@ ones, in case fg and bg are nil." (shr-generic dom) (put-text-property start (point) 'display '(raise -0.5)))) -(defun shr-tag-label (dom) - (shr-generic dom) - (shr-ensure-paragraph)) - (defun shr-tag-p (dom) (shr-ensure-paragraph) (shr-generic dom) (shr-ensure-paragraph)) (defun shr-tag-div (dom) - (shr-ensure-newline) - (shr-generic dom) - (shr-ensure-newline)) + (let ((display (cdr (assq 'display shr-stylesheet)))) + (if (or (equal display "inline") + (equal display "inline-block")) + (shr-generic dom) + (shr-ensure-newline) + (shr-generic dom) + (shr-ensure-newline)))) (defun shr-tag-s (dom) (shr-fontize-dom dom 'shr-strike-through)) @@ -1351,10 +1394,14 @@ ones, in case fg and bg are nil." (defun shr-tag-u (dom) (shr-fontize-dom dom 'underline)) -(defun shr-tag-tt (dom) +(defun shr-tag-code (dom) (let ((shr-current-font 'default)) (shr-generic dom))) +(defun shr-tag-tt (dom) + ;; The `tt' tag is deprecated in favor of `code'. + (shr-tag-code dom)) + (defun shr-tag-ins (cont) (let* ((start (point)) (color "green") @@ -1416,6 +1463,21 @@ ones, in case fg and bg are nil." (when url (shr-urlify (or shr-start start) (shr-expand-url url) title)))) +(defun shr-tag-abbr (dom) + (when-let* ((title (dom-attr dom 'title)) + (start (point))) + (shr-generic dom) + (shr-add-font start (point) 'shr-abbreviation) + (add-text-properties + start (point) + (list + 'help-echo title + 'mouse-face 'highlight)))) + +(defun shr-tag-acronym (dom) + ;; `acronym' is deprecated in favor of `abbr'. + (shr-tag-abbr dom)) + (defun shr-tag-object (dom) (unless shr-inhibit-images (let ((start (point)) @@ -1455,7 +1517,6 @@ The key element should be a regexp matched against the type of the source or url if no type is specified. The value should be a float in the range 0.0 to 1.0. Media elements with higher value are preferred." :version "24.4" - :group 'shr :type '(alist :key-type regexp :value-type float)) (defun shr--get-media-pref (elem) @@ -1528,6 +1589,10 @@ The preference is a float determined from `shr-prefer-media-type'." (when (zerop (length alt)) (setq alt "*")) (cond + ((null url) + ;; After further expansion, there turned out to be no valid + ;; src in the img after all. + ) ((or (member (dom-attr dom 'height) '("0" "1")) (member (dom-attr dom 'width) '("0" "1"))) ;; Ignore zero-sized or single-pixel images. @@ -1662,7 +1727,7 @@ The preference is a float determined from `shr-prefer-media-type'." (svg-gradient svg "background" 'linear '((0 . "#b0b0b0") (100 . "#808080"))) (svg-rectangle svg 0 0 width height :gradient "background" :stroke-width 2 :stroke-color "black") - (let ((image (svg-image svg))) + (let ((image (svg-image svg :scale 1))) (setf (image-property image :ascent) 100) image))) @@ -1710,7 +1775,14 @@ The preference is a float determined from `shr-prefer-media-type'." (defun shr-tag-ol (dom) (shr-ensure-paragraph) - (let ((shr-list-mode 1)) + (let* ((attrs (dom-attributes dom)) + (start-attr (alist-get 'start attrs)) + ;; Start at 1 if there is no start attribute + ;; or if start can't be parsed as an integer. + (start-index (condition-case _ + (cl-parse-integer start-attr) + (t 1))) + (shr-list-mode start-index)) (shr-generic dom)) (shr-ensure-paragraph)) @@ -1738,7 +1810,10 @@ The preference is a float determined from `shr-prefer-media-type'." (defun shr-mark-fill (start) ;; We may not have inserted any text to fill. - (unless (= start (point)) + (when (and (/= start (point)) + ;; Tables insert themselves with the correct indentation, + ;; so don't do anything if we're at the start of a table. + (not (get-text-property start 'shr-table-id))) (put-text-property start (1+ start) 'shr-indentation shr-indentation))) @@ -2035,7 +2110,8 @@ flags that control whether to collect or render objects." (setq max (max max (nth 2 column)))) max))) (dotimes (_ (max height 1)) - (shr-indent) + (when (bolp) + (shr-indent)) (insert shr-table-vertical-line "\n")) (dolist (column row) (when (> (nth 2 column) -1) diff --git a/lisp/net/sieve-manage.el b/lisp/net/sieve-manage.el index 2530d3a0bab..d14475a9d53 100644 --- a/lisp/net/sieve-manage.el +++ b/lisp/net/sieve-manage.el @@ -1,4 +1,4 @@ -;;; sieve-manage.el --- Implementation of the managesieve protocol in elisp +;;; sieve-manage.el --- Implementation of the managesieve protocol in elisp -*- lexical-binding:t -*- ;; Copyright (C) 2001-2019 Free Software Foundation, Inc. @@ -75,9 +75,8 @@ (require 'password-cache) (require 'password)) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'sasl) -(require 'starttls) (autoload 'sasl-find-mechanism "sasl") (autoload 'auth-source-search "auth-source") @@ -182,7 +181,7 @@ Valid states are `closed', `initial', `nonauth', and `auth'.") (generate-new-buffer (format " *sieve %s:%s*" sieve-manage-server sieve-manage-port)) - (mapc 'make-local-variable sieve-manage-local-variables) + (mapc #'make-local-variable sieve-manage-local-variables) (mm-enable-multibyte) (buffer-disable-undo) (current-buffer))) @@ -206,19 +205,19 @@ Return the buffer associated with the connection." (with-current-buffer buffer (sieve-manage-erase) (setq sieve-manage-state 'initial) - (destructuring-bind (proc . props) - (open-network-stream - "SIEVE" buffer server port - :type stream - :capability-command "CAPABILITY\r\n" - :end-of-command "^\\(OK\\|NO\\).*\n" - :success "^OK.*\n" - :return-list t - :starttls-function - (lambda (capabilities) - (when (and (not sieve-manage-ignore-starttls) - (string-match "\\bSTARTTLS\\b" capabilities)) - "STARTTLS\r\n"))) + (pcase-let ((`(,proc . ,props) + (open-network-stream + "SIEVE" buffer server port + :type stream + :capability-command "CAPABILITY\r\n" + :end-of-command "^\\(OK\\|NO\\).*\n" + :success "^OK.*\n" + :return-list t + :starttls-function + (lambda (capabilities) + (when (and (not sieve-manage-ignore-starttls) + (string-match "\\bSTARTTLS\\b" capabilities)) + "STARTTLS\r\n"))))) (setq sieve-manage-process proc) (setq sieve-manage-capability (sieve-manage-parse-capability (plist-get props :capabilities))) @@ -250,7 +249,7 @@ Return the buffer associated with the connection." ;; somehow. `(lambda (prompt) ,(copy-sequence user-password))) (step (sasl-next-step client nil)) - (tag (sieve-manage-send + (_tag (sieve-manage-send (concat "AUTHENTICATE \"" mech @@ -373,11 +372,11 @@ to work in." ;; Choose authenticator (when (and (null sieve-manage-auth) (not (eq sieve-manage-state 'auth))) - (dolist (auth sieve-manage-authenticators) + (cl-dolist (auth sieve-manage-authenticators) (when (funcall (nth 1 (assq auth sieve-manage-authenticator-alist)) buffer) (setq sieve-manage-auth auth) - (return))) + (cl-return))) (unless sieve-manage-auth (error "Couldn't figure out authenticator for server"))) (sieve-manage-erase) diff --git a/lisp/net/sieve-mode.el b/lisp/net/sieve-mode.el index 774047f3aa8..adab010257f 100644 --- a/lisp/net/sieve-mode.el +++ b/lisp/net/sieve-mode.el @@ -100,23 +100,20 @@ (defconst sieve-font-lock-keywords (eval-when-compile - (list - ;; control commands - (cons (regexp-opt '("require" "if" "else" "elsif" "stop") - 'words) - 'sieve-control-commands) - ;; action commands - (cons (regexp-opt '("fileinto" "redirect" "reject" "keep" "discard") - 'words) - 'sieve-action-commands) - ;; test commands - (cons (regexp-opt '("address" "allof" "anyof" "exists" "false" - "true" "header" "not" "size" "envelope" - "body") - 'words) - 'sieve-test-commands) - (cons "\\Sw+:\\sw+" - 'sieve-tagged-arguments)))) + `( + ;; control commands + (,(regexp-opt '("require" "if" "else" "elsif" "stop") 'words) + . 'sieve-control-commands) + ;; action commands + (,(regexp-opt '("fileinto" "redirect" "reject" "keep" "discard") 'words) + . 'sieve-action-commands) + ;; test commands + (,(regexp-opt '("address" "allof" "anyof" "exists" "false" + "true" "header" "not" "size" "envelope" + "body") + 'words) + . 'sieve-test-commands) + ("\\Sw+:\\sw+" . 'sieve-tagged-arguments)))) ;; Syntax table diff --git a/lisp/net/sieve.el b/lisp/net/sieve.el index 0e14af2cc84..3337998bedc 100644 --- a/lisp/net/sieve.el +++ b/lisp/net/sieve.el @@ -137,16 +137,15 @@ require \"fileinto\"; '("Manage Sieve" ["Edit script" sieve-edit-script t] ["Activate script" sieve-activate t] - ["Deactivate script" sieve-deactivate t])) + ["Deactivate script" sieve-deactivate t] + ["Quit and close connection" sieve-manage-quit t])) -(define-derived-mode sieve-manage-mode fundamental-mode "Sieve-manage" +(define-derived-mode sieve-manage-mode special-mode "Sieve-manage" "Mode used for sieve script management." (buffer-disable-undo (current-buffer)) (setq truncate-lines t) (easy-menu-add sieve-manage-mode-menu sieve-manage-mode-map)) -(put 'sieve-manage-mode 'mode-class 'special) - ;; Commands used in sieve-manage mode: (defun sieve-manage-quit () @@ -215,9 +214,9 @@ require \"fileinto\"; (sieve-mode) (setq sieve-buffer-script-name name) (goto-char (point-min)) - (message - (substitute-command-keys - "Press \\[sieve-upload] to upload script to server.")))) + (set-buffer-modified-p nil) + (message "Press %s to upload script to server." + (substitute-command-keys "\\[sieve-upload]")))) (defmacro sieve-change-region (&rest body) "Turns off sieve-region before executing BODY, then re-enables it after. @@ -256,8 +255,10 @@ Used to bracket operations which move point in the sieve-buffer." (if (eq last-command 'sieve-help) ;; would need minor-mode for log-edit-mode (describe-function 'sieve-mode) - (message "%s" (substitute-command-keys - "`\\[sieve-edit-script]':edit `\\[sieve-activate]':activate `\\[sieve-deactivate]':deactivate `\\[sieve-remove]':remove")))) + (message "%s" (substitute-command-keys "\ +`\\[sieve-edit-script]':edit `\\[sieve-activate]':activate \ +`\\[sieve-deactivate]':deactivate `\\[sieve-remove]':remove \ +`\\[sieve-manage-quit]':quit")))) ;; Create buffer: @@ -312,20 +313,20 @@ Used to bracket operations which move point in the sieve-buffer." (delete-region (or sieve-buffer-header-end (point-max)) (point-max)) (goto-char (point-max)) ;; get list of script names and print them - (let ((scripts (sieve-manage-listscripts sieve-manage-buffer))) - (if (null scripts) - (insert - (substitute-command-keys - (format - "No scripts on server, press \\[sieve-edit-script] on %s to create a new script.\n" - sieve-new-script))) - (insert - (substitute-command-keys - (format (concat "%d script%s on server, press \\[sieve-edit-script] on a script " - "name edits it, or\npress \\[sieve-edit-script] on %s to create " - "a new script.\n") (length scripts) - (if (eq (length scripts) 1) "" "s") - sieve-new-script)))) + (let* ((scripts (sieve-manage-listscripts sieve-manage-buffer)) + (count (length scripts)) + (keys (substitute-command-keys "\\[sieve-edit-script]"))) + (insert + (if (null scripts) + (format + "No scripts on server, press %s on %s to create a new script.\n" + keys sieve-new-script) + (format (concat (ngettext "%d script on server" + "%d scripts on server" + count) + ", press %s on a script name to edit it, or" + "\npress %s on %s to create a new script.\n") + count keys keys sieve-new-script))) (save-excursion (sieve-insert-scripts (list sieve-new-script)) (sieve-insert-scripts scripts))) @@ -345,16 +346,20 @@ Used to bracket operations which move point in the sieve-buffer." ;;;###autoload (defun sieve-upload (&optional name) (interactive) - (when (or (get-buffer sieve-buffer) (call-interactively 'sieve-manage)) - (let ((script (buffer-string)) err) + (when (or (get-buffer sieve-buffer) + (save-current-buffer (call-interactively 'sieve-manage))) + (let ((script (buffer-string)) + (script-name (file-name-sans-extension (buffer-name))) + err) (with-current-buffer (get-buffer sieve-buffer) (setq err (sieve-manage-putscript - (or name sieve-buffer-script-name (buffer-name)) + (or name sieve-buffer-script-name script-name) script sieve-manage-buffer)) - (if (sieve-manage-ok-p err) - (message (substitute-command-keys - "Sieve upload done. Use \\[sieve-manage] to manage scripts.")) - (message "Sieve upload failed: %s" (nth 2 err))))))) + (if (not (sieve-manage-ok-p err)) + (message "Sieve upload failed: %s" (nth 2 err)) + (message "Sieve upload done. Use %s to manage scripts." + (substitute-command-keys "\\[sieve-manage]")) + (set-buffer-modified-p nil)))))) ;;;###autoload (defun sieve-upload-and-bury (&optional name) diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index 64c2b9a2367..5526d624f96 100644 --- a/lisp/net/soap-client.el +++ b/lisp/net/soap-client.el @@ -5,7 +5,7 @@ ;; Author: Alexandru Harsanyi <AlexHarsanyi@gmail.com> ;; Author: Thomas Fitzsimmons <fitzsim@fitzsim.org> ;; Created: December, 2009 -;; Version: 3.1.4 +;; Version: 3.1.5 ;; Keywords: soap, web-services, comm, hypermedia ;; Package: soap-client ;; Homepage: https://github.com/alex-hhh/emacs-soap-client @@ -464,8 +464,14 @@ position. This is a specialization of `soap-encode-value' for `soap-xs-basic-type' objects." - (let ((kind (soap-xs-basic-type-kind type))) - + (let ((kind (soap-xs-basic-type-kind type)) + ;; Handle conversions of this form: + ;; (Element (AttrA . "A") (AttrB . "B") "Value here") + ;; to: + ;; <ns:Element AttrA="A" AttrB="B">Value here</ns:Element> + ;; by assuming that if this is a list, it must have attributes + ;; preceding the basic value. + (value (if (listp value) (progn (car (last value))) value))) (when (eq kind 'anyType) (cond ((stringp value) (setq kind 'string)) @@ -629,7 +635,7 @@ disallows them." (<= time-zone-minute 59)) (error "Invalid or unsupported time: %s" date-time-string)) ;; Return a value in a format similar to that returned by decode-time, and - ;; suitable for (apply 'encode-time ...). + ;; suitable for (apply #'encode-time ...). (list second minute hour day month year second-fraction datatype (if has-time-zone (* (rng-xsd-time-to-seconds @@ -685,14 +691,17 @@ This is a specialization of `soap-decode-type' for (anyType (soap-decode-any-type node)) (Array (soap-decode-array node)))))) -(defun soap-type-of (element) - "Return the type of ELEMENT." - ;; Support Emacs < 26 byte-code running in Emacs >= 26 sessions - ;; (Bug#31742). - (let ((type (type-of element))) - (if (eq type 'vector) - (aref element 0) ; For Emacs 25 and earlier. - type))) +(defalias 'soap-type-of + (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 + ;; For Emacs < 26, use our own function. + (lambda (element) + "Return the type of ELEMENT." + (if (vectorp element) + (aref element 0) ;Assume this vector is actually a struct! + ;; This should never happen. + (type-of element))))) ;; Register methods for `soap-xs-basic-type' (let ((tag (soap-type-of (make-soap-xs-basic-type)))) @@ -1343,14 +1352,25 @@ See also `soap-wsdl-resolve-references'." (defun soap-encode-xs-simple-type-attributes (value type) "Encode the XML attributes for VALUE according to TYPE. -The xsi:type and an optional xsi:nil attributes are added. The -attributes are inserted in the current buffer at the current -position. +The attributes are inserted in the current buffer at the current +position. If TYPE has no attributes, the xsi:type attribute and +an optional xsi:nil attribute are added. This is a specialization of `soap-encode-attributes' for `soap-xs-simple-type' objects." - (insert " xsi:type=\"" (soap-element-fq-name type) "\"") - (unless value (insert " xsi:nil=\"true\""))) + (let ((attributes (soap-get-xs-attributes type))) + (dolist (a attributes) + (let ((element-name (soap-element-name a))) + (if (soap-xs-attribute-default a) + (insert " " element-name + "=\"" (soap-xs-attribute-default a) "\"") + (dolist (value-pair value) + (when (equal element-name (symbol-name (car-safe value-pair))) + (insert " " element-name + "=\"" (cdr value-pair) "\"")))))) + (unless attributes + (insert " xsi:type=\"" (soap-element-fq-name type) "\"") + (unless value (insert " xsi:nil=\"true\""))))) (defun soap-encode-xs-simple-type (value type) "Encode the VALUE according to TYPE. @@ -1640,7 +1660,8 @@ This is a specialization of `soap-encode-value' for (array (error "Arrays of type soap-encode-xs-complex-type are handled elsewhere")) ((sequence choice all nil) - (let ((type-list (list type))) + (let ((type-list (list type)) + (type-elements '())) ;; Collect all base types (let ((base (soap-xs-complex-type-base type))) @@ -1648,60 +1669,66 @@ This is a specialization of `soap-encode-value' for (push base type-list) (setq base (soap-xs-complex-type-base base)))) + ;; Collect type elements, eliminating duplicates from the type + ;; hierarchy. (dolist (type type-list) (dolist (element (soap-xs-complex-type-elements type)) - (catch 'done - (let ((instance-count 0)) - (dolist (candidate (soap-get-candidate-elements element)) - (let ((e-name (soap-xs-element-name candidate))) - (if e-name - (let ((e-name (intern e-name))) - (dolist (v value) - (when (equal (car v) e-name) - (cl-incf instance-count) - (soap-encode-value (cdr v) candidate)))) - (if (soap-xs-complex-type-indicator type) - (let ((current-point (point))) - ;; Check if encoding happened by checking if - ;; characters were inserted in the buffer. - (soap-encode-value value candidate) - (when (not (equal current-point (point))) - (cl-incf instance-count))) + (unless (member element type-elements) + (setq type-elements (append type-elements (list element)))))) + + (dolist (element type-elements) + (catch 'done + (let ((instance-count 0)) + (dolist (candidate (soap-get-candidate-elements element)) + (let ((e-name (soap-xs-element-name candidate))) + (if e-name + (let ((e-name (intern e-name))) (dolist (v value) - (let ((current-point (point))) - (soap-encode-value v candidate) - (when (not (equal current-point (point))) - (cl-incf instance-count)))))))) - ;; Do some sanity checking - (let* ((indicator (soap-xs-complex-type-indicator type)) - (element-type (soap-xs-element-type element)) - (reference (soap-xs-element-reference element)) - (e-name (or (soap-xs-element-name element) - (and reference - (soap-xs-element-name reference))))) - (cond ((and (eq indicator 'choice) - (> instance-count 0)) - ;; This was a choice node and we encoded - ;; one instance. - (throw 'done t)) - ((and (not (eq indicator 'choice)) - (= instance-count 0) - (not (soap-xs-element-optional? element)) - (and (soap-xs-complex-type-p element-type) - (not (soap-xs-complex-type-optional-p - element-type)))) - (soap-warning - "While encoding %s: missing non-nillable slot %s" - value e-name)) - ((and (> instance-count 1) - (not (soap-xs-element-multiple? element)) - (and (soap-xs-complex-type-p element-type) - (not (soap-xs-complex-type-multiple-p - element-type)))) - (soap-warning - (concat "While encoding %s: expected single," - " found multiple elements for slot %s") - value e-name)))))))))) + (when (equal (car v) e-name) + (cl-incf instance-count) + (soap-encode-value (cdr v) candidate)))) + (if (soap-xs-complex-type-indicator type) + (let ((current-point (point))) + ;; Check if encoding happened by checking if + ;; characters were inserted in the buffer. + (soap-encode-value value candidate) + (when (not (equal current-point (point))) + (cl-incf instance-count))) + (dolist (v value) + (let ((current-point (point))) + (soap-encode-value v candidate) + (when (not (equal current-point (point))) + (cl-incf instance-count)))))))) + ;; Do some sanity checking + (let* ((indicator (soap-xs-complex-type-indicator type)) + (element-type (soap-xs-element-type element)) + (reference (soap-xs-element-reference element)) + (e-name (or (soap-xs-element-name element) + (and reference + (soap-xs-element-name reference))))) + (cond ((and (eq indicator 'choice) + (> instance-count 0)) + ;; This was a choice node and we encoded + ;; one instance. + (throw 'done t)) + ((and (not (eq indicator 'choice)) + (= instance-count 0) + (not (soap-xs-element-optional? element)) + (and (soap-xs-complex-type-p element-type) + (not (soap-xs-complex-type-optional-p + element-type)))) + (soap-warning + "While encoding %s: missing non-nillable slot %s" + value e-name)) + ((and (> instance-count 1) + (not (soap-xs-element-multiple? element)) + (and (soap-xs-complex-type-p element-type) + (not (soap-xs-complex-type-multiple-p + element-type)))) + (soap-warning + (concat "While encoding %s: expected single," + " found multiple elements for slot %s") + value e-name))))))))) (t (error "Don't know how to encode complex type: %s" (soap-xs-complex-type-indicator type))))) @@ -2334,6 +2361,14 @@ traverse an element tree." (defun soap-parse-server-response () "Error-check and parse the XML contents of the current buffer." (let ((mime-part (mm-dissect-buffer t t))) + (when (and + (equal (mm-handle-media-type mime-part) "multipart/related") + (equal (get-text-property 0 'type (mm-handle-media-type mime-part)) + "text/xml")) + (setq mime-part + (mm-make-handle + (get-text-property 0 'buffer (mm-handle-media-type mime-part)) + `(,(get-text-property 0 'type (mm-handle-media-type mime-part)))))) (unless mime-part (error "Failed to decode response from server")) (unless (equal (car (mm-handle-type mime-part)) "text/xml") @@ -2881,6 +2916,8 @@ reference multiRef parts which are external to RESPONSE-NODE." ;;;; SOAP type encoding +;; FIXME: Use `cl-defmethod' (but this requires Emacs-25). + (defun soap-encode-attributes (value type) "Encode XML attributes for VALUE according to TYPE. This is a generic function which determines the attribute encoder diff --git a/lisp/net/socks.el b/lisp/net/socks.el index c2a8b699cd5..6356707a1db 100644 --- a/lisp/net/socks.el +++ b/lisp/net/socks.el @@ -1,4 +1,4 @@ -;;; socks.el --- A Socks v5 Client for Emacs +;;; socks.el --- A Socks v5 Client for Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1996-2000, 2002, 2007-2019 Free Software Foundation, ;; Inc. @@ -32,71 +32,59 @@ ;; - Implement composition of servers. Recursively evaluate the ;; redirection rules and do SOCKS-over-HTTP and SOCKS-in-SOCKS -(eval-when-compile - (require 'wid-edit)) -(require 'custom) - -(eval-and-compile - (if (featurep 'emacs) - (defalias 'socks-split-string 'split-string) ; since at least 21.1 - (if (fboundp 'split-string) - (defalias 'socks-split-string 'split-string) - (defun socks-split-string (string &optional pattern) - "Return a list of substrings of STRING which are separated by PATTERN. -If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." - (or pattern - (setq pattern "[ \f\t\n\r\v]+")) - (let (parts (start 0)) - (while (string-match pattern string start) - (setq parts (cons (substring string start - (match-beginning 0)) parts) - start (match-end 0))) - (nreverse (cons (substring string start) parts))))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Custom widgets -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; (define-widget 'dynamic-choice 'menu-choice -;;; "A pretty simple dynamic dropdown list" -;;; :format "%[%t%]: %v" -;;; :tag "Network" -;;; :case-fold t -;;; :void '(item :format "invalid (%t)\n") -;;; :value-create 's5-widget-value-create -;;; :value-delete 'widget-children-value-delete -;;; :value-get 'widget-choice-value-get -;;; :value-inline 'widget-choice-value-inline -;;; :mouse-down-action 'widget-choice-mouse-down-action -;;; :action 'widget-choice-action -;;; :error "Make a choice" -;;; :validate 'widget-choice-validate -;;; :match 's5-dynamic-choice-match -;;; :match-inline 's5-dynamic-choice-match-inline) -;;; -;;; (defun s5-dynamic-choice-match (widget value) -;;; (let ((choices (funcall (widget-get widget :choice-function))) -;;; current found) -;;; (while (and choices (not found)) -;;; (setq current (car choices) -;;; choices (cdr choices) -;;; found (widget-apply current :match value))) -;;; found)) -;;; -;;; (defun s5-dynamic-choice-match-inline (widget value) -;;; (let ((choices (funcall (widget-get widget :choice-function))) -;;; current found) -;;; (while (and choices (not found)) -;;; (setq current (car choices) -;;; choices (cdr choices) -;;; found (widget-match-inline current value))) -;;; found)) -;;; -;;; (defun s5-widget-value-create (widget) -;;; (let ((choices (funcall (widget-get widget :choice-function))) -;;; (value (widget-get widget :value))) -;;; (if (not value) -;;; (widget-put widget :value (widget-value (car choices)))) -;;; (widget-put widget :args choices) -;;; (widget-choice-value-create widget))) +;;; Code: + +(eval-when-compile (require 'cl-lib)) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;; Custom widgets +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (eval-when-compile +;; (require 'wid-edit)) + +;; (define-widget 'dynamic-choice 'menu-choice +;; "A pretty simple dynamic dropdown list" +;; :format "%[%t%]: %v" +;; :tag "Network" +;; :case-fold t +;; :void '(item :format "invalid (%t)\n") +;; :value-create 's5-widget-value-create +;; :value-delete 'widget-children-value-delete +;; :value-get 'widget-choice-value-get +;; :value-inline 'widget-choice-value-inline +;; :mouse-down-action 'widget-choice-mouse-down-action +;; :action 'widget-choice-action +;; :error "Make a choice" +;; :validate 'widget-choice-validate +;; :match 's5-dynamic-choice-match +;; :match-inline 's5-dynamic-choice-match-inline) +;; +;; (defun s5-dynamic-choice-match (widget value) +;; (let ((choices (funcall (widget-get widget :choice-function))) +;; current found) +;; (while (and choices (not found)) +;; (setq current (car choices) +;; choices (cdr choices) +;; found (widget-apply current :match value))) +;; found)) +;; +;; (defun s5-dynamic-choice-match-inline (widget value) +;; (let ((choices (funcall (widget-get widget :choice-function))) +;; current found) +;; (while (and choices (not found)) +;; (setq current (car choices) +;; choices (cdr choices) +;; found (widget-match-inline current value))) +;; found)) +;; +;; (defun s5-widget-value-create (widget) +;; (let ((choices (funcall (widget-get widget :choice-function))) +;; (value (widget-get widget :value))) +;; (if (not value) +;; (widget-put widget :value (widget-value (car choices)))) +;; (widget-put widget :args choices) +;; (widget-choice-value-create widget))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Customization support @@ -107,70 +95,66 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." :prefix "socks-" :group 'processes) -;;; (defcustom socks-server-aliases nil -;;; "A list of server aliases for use in access control and filtering rules." -;;; :group 'socks -;;; :type '(repeat (list :format "%v" -;;; :value ("" "" 1080 5) -;;; (string :tag "Alias") -;;; (string :tag "Hostname/IP Address") -;;; (integer :tag "Port #") -;;; (choice :tag "SOCKS Version" -;;; (integer :tag "SOCKS v4" :value 4) -;;; (integer :tag "SOCKS v5" :value 5))))) -;;; -;;; (defcustom socks-network-aliases -;;; '(("Anywhere" (netmask "0.0.0.0" "0.0.0.0"))) -;;; "A list of network aliases for use in subsequent rules." -;;; :group 'socks -;;; :type '(repeat (list :format "%v" -;;; :value (netmask "" "255.255.255.0") -;;; (string :tag "Alias") -;;; (radio-button-choice -;;; :format "%v" -;;; (list :tag "IP address range" -;;; (const :format "" :value range) -;;; (string :tag "From") -;;; (string :tag "To")) -;;; (list :tag "IP address/netmask" -;;; (const :format "" :value netmask) -;;; (string :tag "IP Address") -;;; (string :tag "Netmask")) -;;; (list :tag "Domain Name" -;;; (const :format "" :value domain) -;;; (string :tag "Domain name")) -;;; (list :tag "Unique hostname/IP address" -;;; (const :format "" :value exact) -;;; (string :tag "Hostname/IP Address")))))) -;;; -;;; (defun s5-servers-filter () -;;; (if socks-server-aliases -;;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x))) s5-server-aliases) -;;; '((const :tag "No aliases defined" :value nil)))) -;;; -;;; (defun s5-network-aliases-filter () -;;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x))) -;;; socks-network-aliases)) -;;; -;;; (defcustom socks-redirection-rules -;;; nil -;;; "A list of redirection rules." -;;; :group 'socks -;;; :type '(repeat (list :format "%v" -;;; :value ("Anywhere" nil) -;;; (dynamic-choice :choice-function s5-network-aliases-filter -;;; :tag "Destination network") -;;; (radio-button-choice -;;; :tag "Connection type" -;;; (const :tag "Direct connection" :value nil) -;;; (dynamic-choice :format "%t: %[%v%]" -;;; :choice-function s5-servers-filter -;;; :tag "Proxy chain via"))))) +;; (defcustom socks-server-aliases nil +;; "A list of server aliases for use in access control and filtering rules." +;; :type '(repeat (list :format "%v" +;; :value ("" "" 1080 5) +;; (string :tag "Alias") +;; (string :tag "Hostname/IP Address") +;; (integer :tag "Port #") +;; (choice :tag "SOCKS Version" +;; (integer :tag "SOCKS v4" :value 4) +;; (integer :tag "SOCKS v5" :value 5))))) +;; +;; (defcustom socks-network-aliases +;; '(("Anywhere" (netmask "0.0.0.0" "0.0.0.0"))) +;; "A list of network aliases for use in subsequent rules." +;; :type '(repeat (list :format "%v" +;; :value (netmask "" "255.255.255.0") +;; (string :tag "Alias") +;; (radio-button-choice +;; :format "%v" +;; (list :tag "IP address range" +;; (const :format "" :value range) +;; (string :tag "From") +;; (string :tag "To")) +;; (list :tag "IP address/netmask" +;; (const :format "" :value netmask) +;; (string :tag "IP Address") +;; (string :tag "Netmask")) +;; (list :tag "Domain Name" +;; (const :format "" :value domain) +;; (string :tag "Domain name")) +;; (list :tag "Unique hostname/IP address" +;; (const :format "" :value exact) +;; (string :tag "Hostname/IP Address")))))) +;; +;; (defun s5-servers-filter () +;; (if socks-server-aliases +;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x))) s5-server-aliases) +;; '((const :tag "No aliases defined" :value nil)))) +;; +;; (defun s5-network-aliases-filter () +;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x))) +;; socks-network-aliases)) +;; +;; (defcustom socks-redirection-rules +;; nil +;; "A list of redirection rules." +;; :type '(repeat (list :format "%v" +;; :value ("Anywhere" nil) +;; (dynamic-choice :choice-function s5-network-aliases-filter +;; :tag "Destination network") +;; (radio-button-choice +;; :tag "Connection type" +;; (const :tag "Direct connection" :value nil) +;; (dynamic-choice :format "%t: %[%v%]" +;; :choice-function s5-servers-filter +;; :tag "Proxy chain via"))))) (defcustom socks-server (list "Default server" "socks" 1080 5) "" - :group 'socks :type '(list (string :format "" :value "Default server") (string :tag "Server") @@ -225,7 +209,6 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." ;; Base variables (defvar socks-timeout 5) -(defvar socks-connections (make-hash-table :size 13)) ;; Miscellaneous stuff for authentication (defvar socks-authentication-methods nil) @@ -266,40 +249,40 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (defconst socks-state-waiting 3) (defconst socks-state-connected 4) -(defmacro socks-wait-for-state-change (proc htable cur-state) - `(while (and (= (gethash 'state ,htable) ,cur-state) - (memq (process-status ,proc) '(run open))) - (accept-process-output ,proc socks-timeout))) +(defun socks-wait-for-state-change (proc cur-state) + (while (and (= (process-get proc 'socks-state) cur-state) + (memq (process-status proc) '(run open))) + (accept-process-output proc socks-timeout))) (defun socks-filter (proc string) - (let ((info (gethash proc socks-connections)) - state version desired-len) - (or info (error "socks-filter called on non-SOCKS connection %S" proc)) - (setq state (gethash 'state info)) + (let (state version desired-len) + (or (process-get proc 'socks) + (error "socks-filter called on non-SOCKS connection %S" proc)) + (setq state (process-get proc 'socks-state)) (cond ((= state socks-state-waiting-for-auth) - (puthash 'scratch (concat string (gethash 'scratch info)) info) - (setq string (gethash 'scratch info)) + (cl-callf (lambda (s) (setq string (concat string s))) + (process-get proc 'socks-scratch)) (if (< (length string) 2) nil ; We need to spin some more - (puthash 'authtype (aref string 1) info) - (puthash 'scratch (substring string 2 nil) info) - (puthash 'state socks-state-submethod-negotiation info))) + (process-put proc 'socks-authtype (aref string 1)) + (process-put proc 'socks-scratch (substring string 2 nil)) + (process-put proc 'socks-state socks-state-submethod-negotiation))) ((= state socks-state-submethod-negotiation) ) ((= state socks-state-authenticated) ) ((= state socks-state-waiting) - (puthash 'scratch (concat string (gethash 'scratch info)) info) - (setq string (gethash 'scratch info)) - (setq version (gethash 'server-protocol info)) + (cl-callf (lambda (s) (setq string (concat string s))) + (process-get proc 'socks-scratch)) + (setq version (process-get proc 'socks-server-protocol)) (cond ((equal version 'http) (if (not (string-match "\r\n\r\n" string)) nil ; Need to spin some more - (puthash 'state socks-state-connected info) - (puthash 'reply 0 info) - (puthash 'response string info))) + (process-put proc 'socks-state socks-state-connected) + (process-put proc 'socks-reply 0) + (process-put proc 'socks-response string))) ((equal version 4) (if (< (length string) 2) nil ; Can't know how much to read yet @@ -313,71 +296,58 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (let ((response (aref string 1))) (if (= response 90) (setq response 0)) - (puthash 'state socks-state-connected info) - (puthash 'reply response info) - (puthash 'response string info))))) + (process-put proc 'socks-state socks-state-connected) + (process-put proc 'socks-reply response) + (process-put proc 'socks-response string))))) ((equal version 5) (if (< (length string) 4) nil (setq desired-len (+ 6 ; Standard socks header - (cond - ((= (aref string 3) socks-address-type-v4) 4) - ((= (aref string 3) socks-address-type-v6) 16) - ((= (aref string 3) socks-address-type-name) - (if (< (length string) 5) - 255 - (+ 1 (aref string 4))))))) + (pcase (aref string 3) + ((pred (= socks-address-type-v4)) 4) + ((pred (= socks-address-type-v6)) 16) + ((pred (= socks-address-type-name)) + (if (< (length string) 5) + 255 + (+ 1 (aref string 4))))))) (if (< (length string) desired-len) nil ; Need to spin some more - (puthash 'state socks-state-connected info) - (puthash 'reply (aref string 1) info) - (puthash 'response string info)))))) - ((= state socks-state-connected) - ) - ) - ) - ) - -(declare-function socks-original-open-network-stream "socks") ; fset + (process-put proc 'socks-state socks-state-connected) + (process-put proc 'socks-reply (aref string 1)) + (process-put proc 'socks-response string)))))) + ((= state socks-state-connected))))) ;; FIXME this is a terrible idea. ;; It is not even compatible with the argument spec of open-network-stream -;; in 24.1. If this is really necessary, open-network-stream -;; could get a wrapper hook, or defer to open-network-stream-function. +;; in 24.1. (defvar socks-override-functions nil - "Whether to overwrite the `open-network-stream' function with the SOCKSified -version.") - -(require 'network-stream) + "If non-nil, overwrite `open-network-stream' function with SOCKSified version.") -(if (fboundp 'socks-original-open-network-stream) - nil ; Do nothing, we've been here already - (defalias 'socks-original-open-network-stream - (symbol-function 'open-network-stream)) - (if socks-override-functions - (defalias 'open-network-stream 'socks-open-network-stream))) +(when socks-override-functions + (advice-add 'open-network-stream :around #'socks--open-network-stream)) (defun socks-open-connection (server-info) (interactive) (save-excursion - (let ((proc (socks-original-open-network-stream "socks" - nil - (nth 1 server-info) - (nth 2 server-info))) - (info (make-hash-table :size 13)) + (let ((proc + (let ((socks-override-functions nil)) + (open-network-stream "socks" + nil + (nth 1 server-info) + (nth 2 server-info)))) (authtype nil) version) ;; Initialize process and info about the process - (set-process-filter proc 'socks-filter) + (set-process-filter proc #'socks-filter) (set-process-query-on-exit-flag proc nil) - (puthash proc info socks-connections) - (puthash 'state socks-state-waiting-for-auth info) - (puthash 'authtype socks-authentication-failure info) - (puthash 'server-protocol (nth 3 server-info) info) - (puthash 'server-name (nth 1 server-info) info) + (process-put proc 'socks t) + (process-put proc 'socks-state socks-state-waiting-for-auth) + (process-put proc 'socks-authtype socks-authentication-failure) + (process-put proc 'socks-server-protocol (nth 3 server-info)) + (process-put proc 'socks-server-name (nth 1 server-info)) (setq version (nth 3 server-info)) (cond ((equal version 'http) @@ -393,15 +363,15 @@ version.") (socks-build-auth-list))) ;; Basically just do a select() until we change states. - (socks-wait-for-state-change proc info socks-state-waiting-for-auth) - (setq authtype (gethash 'authtype info)) + (socks-wait-for-state-change proc socks-state-waiting-for-auth) + (setq authtype (process-get proc 'socks-authtype)) (cond ((= authtype socks-authentication-null) (and socks-debug (message "No authentication necessary"))) ((= authtype socks-authentication-failure) (error "No acceptable authentication methods found")) (t - (let* ((auth-type (gethash 'authtype info)) + (let* ((auth-type (process-get proc 'socks-authtype)) (auth-handler (assoc auth-type socks-authentication-methods)) (auth-func (and auth-handler (cdr (cdr auth-handler)))) (auth-desc (and auth-handler (car (cdr auth-handler))))) @@ -415,8 +385,8 @@ version.") ) ) ) - (puthash 'state socks-state-authenticated info) - (set-process-filter proc 'socks-filter))) + (process-put proc 'socks-state socks-state-authenticated) + (set-process-filter proc #'socks-filter))) proc))) (defun socks-send-command (proc command atype address port) @@ -428,12 +398,11 @@ version.") (format "%c%s" (length address) address)) (t (error "Unknown address type: %d" atype)))) - (info (gethash proc socks-connections)) request version) - (or info (error "socks-send-command called on non-SOCKS connection %S" - proc)) - (puthash 'state socks-state-waiting info) - (setq version (gethash 'server-protocol info)) + (or (process-get proc 'socks) + (error "socks-send-command called on non-SOCKS connection %S" proc)) + (process-put proc 'socks-state socks-state-waiting) + (setq version (process-get proc 'socks-server-protocol)) (cond ((equal version 'http) (setq request (format (eval-when-compile @@ -447,38 +416,36 @@ version.") (error "Unsupported address type for HTTP: %d" atype))) port))) ((equal version 4) - (setq request (string-make-unibyte - (format - "%c%c%c%c%s%s%c" - version ; version - command ; command - (lsh port -8) ; port, high byte - (- port (lsh (lsh port -8) 8)) ; port, low byte - addr ; address - (user-full-name) ; username - 0 ; terminate username - )))) + (setq request (concat + (unibyte-string + version ; version + command ; command + (ash port -8) ; port, high byte + (logand port #xff)) ; port, low byte + addr ; address + (user-full-name) ; username + "\0"))) ; terminate username ((equal version 5) - (setq request (string-make-unibyte - (format - "%c%c%c%c%s%c%c" + (setq request (concat + (unibyte-string version ; version command ; command 0 ; reserved - atype ; address type - addr ; address - (lsh port -8) ; port, high byte - (- port (lsh (lsh port -8) 8)) ; port, low byte - )))) + atype) ; address type + addr ; address + (unibyte-string + (ash port -8) ; port, high byte + (logand port #xff))))) ; port, low byte (t (error "Unknown protocol version: %d" version))) (process-send-string proc request) - (socks-wait-for-state-change proc info socks-state-waiting) + (socks-wait-for-state-change proc socks-state-waiting) (process-status proc) - (if (= (or (gethash 'reply info) 1) socks-response-success) + (if (= (or (process-get proc 'socks-reply) 1) socks-response-success) nil ; Sweet sweet success! (delete-process proc) - (error "SOCKS: %s" (nth (or (gethash 'reply info) 1) socks-errors))) + (error "SOCKS: %s" + (nth (or (process-get proc 'socks-reply) 1) socks-errors))) proc)) @@ -486,7 +453,7 @@ version.") (defvar socks-noproxy nil "List of regexps matching hosts that we should not socksify connections to") -(defun socks-find-route (host service) +(defun socks-find-route (host _service) (let ((route socks-server) (noproxy socks-noproxy)) (while noproxy @@ -540,37 +507,46 @@ version.") (if udp socks-udp-services socks-tcp-services))) (defun socks-open-network-stream (name buffer host service) - (let* ((route (socks-find-route host service)) - proc info version atype) + (let ((socks-override-functions t)) + (socks--open-network-stream + (lambda (&rest args) + (let ((socks-override-functions nil)) + (apply #'open-network-stream args))) + name buffer host service))) + +(defun socks--open-network-stream (orig-fun name buffer host service &rest params) + (let ((route (and socks-override-functions + (socks-find-route host service)))) (if (not route) - (socks-original-open-network-stream name buffer host service) - (setq proc (socks-open-connection route) - info (gethash proc socks-connections) - version (gethash 'server-protocol info)) - (cond - ((equal version 4) - (setq host (socks-nslookup-host host)) - (if (not (listp host)) - (error "Could not get IP address for: %s" host)) - (setq host (apply 'format "%c%c%c%c" host)) - (setq atype socks-address-type-v4)) - (t - (setq atype socks-address-type-name))) - (socks-send-command proc - socks-connect-command - atype - host - (if (stringp service) - (or - (socks-find-services-entry service) - (error "Unknown service: %s" service)) - service)) - (puthash 'buffer buffer info) - (puthash 'host host info) - (puthash 'service host info) - (set-process-filter proc nil) - (set-process-buffer proc (if buffer (get-buffer-create buffer))) - proc))) + (apply orig-fun name buffer host service params) + ;; FIXME: Obey `params'! + (let* ((proc (socks-open-connection route)) + (version (process-get proc 'socks-server-protocol)) + (atype + (cond + ((equal version 4) + (setq host (socks-nslookup-host host)) + (if (not (listp host)) + (error "Could not get IP address for: %s" host)) + (setq host (apply #'format "%c%c%c%c" host)) + socks-address-type-v4) + (t + socks-address-type-name)))) + (socks-send-command proc + socks-connect-command + atype + host + (if (stringp service) + (or + (socks-find-services-entry service) + (error "Unknown service: %s" service)) + service)) + (process-put proc 'socks-buffer buffer) + (process-put proc 'socks-host host) + (process-put proc 'socks-service host) + (set-process-filter proc nil) + (set-process-buffer proc (if buffer (get-buffer-create buffer))) + proc)))) ;; Authentication modules go here @@ -581,24 +557,25 @@ version.") (defconst socks-username/password-auth-version 1) (defun socks-username/password-auth-filter (proc str) - (let ((info (gethash proc socks-connections))) - (or info (error "socks-filter called on non-SOCKS connection %S" proc)) - (puthash 'scratch (concat (gethash 'scratch info) str) info) - (if (< (length (gethash 'scratch info)) 2) - nil - (puthash 'password-auth-status (aref (gethash 'scratch info) 1) info) - (puthash 'state socks-state-authenticated info)))) + (or (process-get proc 'socks) + (error "socks-filter called on non-SOCKS connection %S" proc)) + (cl-callf (lambda (s) (concat s str)) + (process-get proc 'socks-scratch)) + (if (< (length (process-get proc 'socks-scratch)) 2) + nil + (process-put proc 'socks-password-auth-status + (aref (process-get proc 'socks-scratch) 1)) + (process-put proc 'socks-state socks-state-authenticated))) (defun socks-username/password-auth (proc) - (let* ((info (gethash proc socks-connections)) - (state (gethash 'state info))) + (let ((state (process-get proc 'socks-state))) (if (not socks-password) (setq socks-password (read-passwd (format "Password for %s@%s: " socks-username - (gethash 'server-name info))))) - (puthash 'scratch "" info) - (set-process-filter proc 'socks-username/password-auth-filter) + (process-get proc 'socks-server-name))))) + (process-put proc 'socks-scratch "") + (set-process-filter proc #'socks-username/password-auth-filter) (process-send-string proc (format "%c%c%s%c%s" socks-username/password-auth-version @@ -606,33 +583,32 @@ version.") socks-username (length socks-password) socks-password)) - (socks-wait-for-state-change proc info state) - (= (gethash 'password-auth-status info) 0))) + (socks-wait-for-state-change proc state) + (= (process-get proc 'socks-password-auth-status) 0))) ;; More advanced GSS/API stuff, not yet implemented - volunteers? ;; (socks-register-authentication-method 1 "GSS/API" 'socks-gssapi-auth) -(defun socks-gssapi-auth (proc) +(defun socks-gssapi-auth (_proc) nil) ;; CHAP stuff ;; (socks-register-authentication-method 3 "CHAP" 'socks-chap-auth) -(defun socks-chap-auth (proc) +(defun socks-chap-auth (_proc) nil) ;; CRAM stuff ;; (socks-register-authentication-method 5 "CRAM" 'socks-cram-auth) -(defun socks-cram-auth (proc) +(defun socks-cram-auth (_proc) nil) (defcustom socks-nslookup-program "nslookup" - "If non-NIL then a string naming the nslookup program." - :type '(choice (const :tag "None" :value nil) string) - :group 'socks) + "If non-nil then a string naming the nslookup program." + :type '(choice (const :tag "None" :value nil) string)) (defun socks-nslookup-host (host) "Attempt to resolve the given HOSTNAME using nslookup if possible." @@ -651,8 +627,8 @@ version.") (progn (setq res (buffer-substring (match-beginning 2) (match-end 2)) - res (mapcar 'string-to-number - (socks-split-string res "\\."))))) + res (mapcar #'string-to-number + (split-string res "\\."))))) (kill-buffer (current-buffer))) res) host)) diff --git a/lisp/net/starttls.el b/lisp/net/starttls.el deleted file mode 100644 index 4087a562448..00000000000 --- a/lisp/net/starttls.el +++ /dev/null @@ -1,304 +0,0 @@ -;;; starttls.el --- STARTTLS functions - -;; Copyright (C) 1999-2019 Free Software Foundation, Inc. - -;; Author: Daiki Ueno <ueno@unixuser.org> -;; Author: Simon Josefsson <simon@josefsson.org> -;; Created: 1999/11/20 -;; Keywords: TLS, SSL, OpenSSL, GnuTLS, mail, news - -;; 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 <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This module defines some utility functions for STARTTLS profiles. - -;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP" -;; by Chris Newman <chris.newman@innosoft.com> (1999/06) - -;; This file now contains a combination of the two previous -;; implementations both called "starttls.el". The first one is Daiki -;; Ueno's starttls.el which uses his own "starttls" command line tool, -;; and the second one is Simon Josefsson's starttls.el which uses -;; "gnutls-cli" from GnuTLS. -;; -;; If "starttls" is available, it is preferred by the code over -;; "gnutls-cli", for backwards compatibility. Use -;; `starttls-use-gnutls' to toggle between implementations if you have -;; both tools installed. It is recommended to use GnuTLS, though, as -;; it performs more verification of the certificates. - -;; The GnuTLS support requires GnuTLS 0.9.90 (released 2003-10-08) or -;; later, from <https://www.gnu.org/software/gnutls/>, or "starttls" -;; from <ftp://ftp.opaopa.org/pub/elisp/>. - -;; Usage is similar to `open-network-stream'. For example: -;; -;; (when (setq tmp (starttls-open-stream -;; "test" (current-buffer) "yxa.extundo.com" 25)) -;; (accept-process-output tmp 15) -;; (process-send-string tmp "STARTTLS\n") -;; (accept-process-output tmp 15) -;; (message "STARTTLS output:\n%s" (starttls-negotiate tmp)) -;; (process-send-string tmp "EHLO foo\n")) - -;; An example run yields the following output: -;; -;; 220 yxa.extundo.com ESMTP Sendmail 8.12.11/8.12.11/Debian-3; Wed, 26 May 2004 19:12:29 +0200; (No UCE/UBE) logging access from: c494102a.s-bi.bostream.se(OK)-c494102a.s-bi.bostream.se [217.215.27.65] -;; 220 2.0.0 Ready to start TLS -;; 250-yxa.extundo.com Hello c494102a.s-bi.bostream.se [217.215.27.65], pleased to meet you -;; 250-ENHANCEDSTATUSCODES -;; 250-PIPELINING -;; 250-EXPN -;; 250-VERB -;; 250-8BITMIME -;; 250-SIZE -;; 250-DSN -;; 250-ETRN -;; 250-AUTH DIGEST-MD5 CRAM-MD5 PLAIN LOGIN -;; 250-DELIVERBY -;; 250 HELP -;; nil -;; -;; With the message buffer containing: -;; -;; STARTTLS output: -;; *** Starting TLS handshake -;; - Server's trusted authorities: -;; [0]: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; - Certificate type: X.509 -;; - Got a certificate list of 2 certificates. -;; -;; - Certificate[0] info: -;; # The hostname in the certificate matches 'yxa.extundo.com'. -;; # valid since: Wed May 26 12:16:00 CEST 2004 -;; # expires at: Wed Jul 26 12:16:00 CEST 2023 -;; # serial number: 04 -;; # fingerprint: 7c 04 4b c1 fa 26 9b 5d 90 22 52 3c 65 3d 85 3a -;; # version: #1 -;; # public key algorithm: RSA -;; # Modulus: 1024 bits -;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=Mail server,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; -;; - Certificate[1] info: -;; # valid since: Sun May 23 11:35:00 CEST 2004 -;; # expires at: Sun Jul 23 11:35:00 CEST 2023 -;; # serial number: 00 -;; # fingerprint: fc 76 d8 63 1a c9 0b 3b fa 40 fe ed 47 7a 58 ae -;; # version: #3 -;; # public key algorithm: RSA -;; # Modulus: 1024 bits -;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; -;; - Peer's certificate issuer is unknown -;; - Peer's certificate is NOT trusted -;; - Version: TLS 1.0 -;; - Key Exchange: RSA -;; - Cipher: ARCFOUR 128 -;; - MAC: SHA -;; - Compression: NULL - -;;; Code: - -(defgroup starttls nil - "Support for `Transport Layer Security' protocol." - :version "21.1" - :group 'mail) - -(defcustom starttls-gnutls-program "gnutls-cli" - "Name of GnuTLS command line tool. -This program is used when GnuTLS is used, i.e. when -`starttls-use-gnutls' is non-nil." - :version "22.1" - :type 'string - :group 'starttls) - -(defcustom starttls-program "starttls" - "The program to run in a subprocess to open an TLSv1 connection. -This program is used when the `starttls' command is used, -i.e. when `starttls-use-gnutls' is nil." - :type 'string - :group 'starttls) - -(defcustom starttls-use-gnutls (not (executable-find starttls-program)) - "Whether to use GnuTLS instead of the `starttls' command." - :version "22.1" - :type 'boolean - :group 'starttls) - -(defcustom starttls-extra-args nil - "Extra arguments to `starttls-program'. -These apply when the `starttls' command is used, i.e. when -`starttls-use-gnutls' is nil." - :type '(repeat string) - :group 'starttls) - -(defcustom starttls-extra-arguments nil - "Extra arguments to `starttls-gnutls-program'. -These apply when GnuTLS is used, i.e. when `starttls-use-gnutls' is non-nil. - -For example, non-TLS compliant servers may require -\(\"--protocols\" \"ssl3\"). Invoke \"gnutls-cli --help\" to -find out which parameters are available." - :version "22.1" - :type '(repeat string) - :group 'starttls) - -(defcustom starttls-process-connection-type nil - "Value for `process-connection-type' to use when starting STARTTLS process." - :version "22.1" - :type 'boolean - :group 'starttls) - -(defcustom starttls-connect "- Simple Client Mode:\n\n" - "Regular expression indicating successful connection. -The default is what GnuTLS's \"gnutls-cli\" outputs." - ;; GnuTLS cli.c:main() prints this string when it is starting to run - ;; in the application read/write phase. If the logic, or the string - ;; itself, is modified, this must be updated. - :version "22.1" - :type 'regexp - :group 'starttls) - -(defcustom starttls-failure "\\*\\*\\* Handshake has failed" - "Regular expression indicating failed TLS handshake. -The default is what GnuTLS's \"gnutls-cli\" outputs." - ;; GnuTLS cli.c:do_handshake() prints this string on failure. If the - ;; logic, or the string itself, is modified, this must be updated. - :version "22.1" - :type 'regexp - :group 'starttls) - -(defcustom starttls-success "- Compression: " - "Regular expression indicating completed TLS handshakes. -The default is what GnuTLS's \"gnutls-cli\" outputs." - ;; GnuTLS cli.c:do_handshake() calls, on success, - ;; common.c:print_info(), that unconditionally print this string - ;; last. If that logic, or the string itself, is modified, this - ;; must be updated. - :version "22.1" - :type 'regexp - :group 'starttls) - -(defun starttls-negotiate-gnutls (process) - "Negotiate TLS on PROCESS opened by `open-starttls-stream'. -This should typically only be done once. It typically returns a -multi-line informational message with information about the -handshake, or nil on failure." - (let (buffer info old-max done-ok done-bad) - (if (null (setq buffer (process-buffer process))) - ;; XXX How to remove/extract the TLS negotiation junk? - (signal-process (process-id process) 'SIGALRM) - (with-current-buffer buffer - (save-excursion - (setq old-max (goto-char (point-max))) - (signal-process (process-id process) 'SIGALRM) - (while (and (processp process) - (eq (process-status process) 'run) - (save-excursion - (goto-char old-max) - (not (or (setq done-ok (re-search-forward - starttls-success nil t)) - (setq done-bad (re-search-forward - starttls-failure nil t)))))) - (accept-process-output process 1 100) - (sit-for 0.1)) - (setq info (buffer-substring-no-properties old-max (point-max))) - (delete-region old-max (point-max)) - (if (or (and done-ok (not done-bad)) - ;; Prevent mitm that fake success msg after failure msg. - (and done-ok done-bad (< done-ok done-bad))) - info - (message "STARTTLS negotiation failed: %s" info) - nil)))))) - -(defun starttls-negotiate (process) - (if starttls-use-gnutls - (starttls-negotiate-gnutls process) - (signal-process (process-id process) 'SIGALRM))) - -(defun starttls-open-stream-gnutls (name buffer host port) - (message "Opening STARTTLS connection to `%s:%s'..." host port) - (let* (done - (old-max (with-current-buffer buffer (point-max))) - (process-connection-type starttls-process-connection-type) - (process (apply #'start-process name buffer - starttls-gnutls-program "-s" host - "-p" (if (integerp port) - (int-to-string port) - port) - starttls-extra-arguments))) - (set-process-query-on-exit-flag process nil) - (while (and (processp process) - (eq (process-status process) 'run) - (with-current-buffer buffer - (goto-char old-max) - (not (setq done (re-search-forward - starttls-connect nil t))))) - (accept-process-output process 0 100) - (sit-for 0.1)) - (if done - (with-current-buffer buffer - (delete-region old-max done)) - (delete-process process) - (setq process nil)) - (message "Opening STARTTLS connection to `%s:%s'...%s" - host port (if done "done" "failed")) - process)) - -;;;###autoload -(defun starttls-open-stream (name buffer host port) - "Open a TLS connection for a port to a host. -Returns a subprocess object to represent the connection. -Input and output work as for subprocesses; `delete-process' closes it. -Args are NAME BUFFER HOST PORT. -NAME is name for process. It is modified if necessary to make it unique. -BUFFER is the buffer (or `buffer-name') to associate with the process. - Process output goes at end of that buffer, unless you specify - a filter function to handle the output. - BUFFER may be also nil, meaning that this process is not associated - with any buffer -Third arg is name of the host to connect to, or its IP address. -Fourth arg PORT is an integer specifying a port to connect to. -If `starttls-use-gnutls' is nil, this may also be a service name, but -GnuTLS requires a port number." - (if starttls-use-gnutls - (starttls-open-stream-gnutls name buffer host port) - (message "Opening STARTTLS connection to `%s:%s'" host (format "%s" port)) - (let* ((process-connection-type starttls-process-connection-type) - (process (apply #'start-process - name buffer starttls-program - host (format "%s" port) - starttls-extra-args))) - (set-process-query-on-exit-flag process nil) - process))) - -(defun starttls-available-p () - "Say whether the STARTTLS programs are available." - (and (not (memq system-type '(windows-nt ms-dos))) - (executable-find (if starttls-use-gnutls - starttls-gnutls-program - starttls-program)))) - -(defalias 'starttls-any-program-available 'starttls-available-p) -(make-obsolete 'starttls-any-program-available 'starttls-available-p - "2011-08-02") - -(provide 'starttls) - -;;; starttls.el ends here diff --git a/lisp/net/telnet.el b/lisp/net/telnet.el index cf3634f7d92..5d23ee3dce7 100644 --- a/lisp/net/telnet.el +++ b/lisp/net/telnet.el @@ -95,11 +95,22 @@ After this many passes, we stop looking for initial setup data. Should be set to the number of terminal writes telnet will make rejecting one login and prompting again for a username and password.") +(defvar telnet-connect-command nil + "Command used to start the `telnet' (or `rsh') connection.") + (defun telnet-interrupt-subjob () "Interrupt the program running through telnet on the remote host." (interactive) (process-send-string nil telnet-interrupt-string)) +(defun telnet-revert-buffer (ignore-auto noconfirm) + (if buffer-file-name + (let (revert-buffer-function) + (revert-buffer ignore-auto noconfirm)) + (if (or noconfirm + (yes-or-no-p (format "Restart connection? "))) + (apply telnet-connect-command)))) + (defun telnet-c-z () (interactive) (process-send-string nil "\C-z")) @@ -229,6 +240,7 @@ Normally input is edited in Emacs and sent a line at a time." (if port " " "") (or port "") "\n")) (telnet-mode) + (setq-local telnet-connect-command (list 'telnet host port)) (setq comint-input-sender 'telnet-simple-send) (setq telnet-count telnet-initial-count)))) @@ -240,6 +252,7 @@ It has most of the same commands as comint-mode. There is a variable `telnet-interrupt-string' which is the character sent to try to stop execution of a job on the remote host. Data is sent to the remote host when RET is typed." + (setq-local revert-buffer-function 'telnet-revert-buffer) (set (make-local-variable 'window-point-insertion-type) t) (set (make-local-variable 'comint-prompt-regexp) telnet-prompt-pattern) (set (make-local-variable 'comint-use-prompt-regexp) t)) @@ -255,6 +268,7 @@ Normally input is edited in Emacs and sent a line at a time." (switch-to-buffer (make-comint name remote-shell-program nil host)) (set-process-filter (get-process name) 'telnet-initial-filter) (telnet-mode) + (setq-local telnet-connect-command (list 'rsh host)) (setq telnet-count -16))) (provide 'telnet) diff --git a/lisp/net/tls.el b/lisp/net/tls.el deleted file mode 100644 index 83f7d18984b..00000000000 --- a/lisp/net/tls.el +++ /dev/null @@ -1,301 +0,0 @@ -;;; tls.el --- TLS/SSL support via wrapper around GnuTLS - -;; Copyright (C) 1996-1999, 2002-2019 Free Software Foundation, Inc. - -;; Author: Simon Josefsson <simon@josefsson.org> -;; Keywords: comm, tls, gnutls, ssl - -;; 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 <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This package implements a simple wrapper around "gnutls-cli" to -;; make Emacs support TLS/SSL. -;; -;; Usage is the same as `open-network-stream', i.e.: -;; -;; (setq tmp (open-tls-stream "test" (current-buffer) "news.mozilla.org" 563)) -;; ... -;; #<process test> -;; (process-send-string tmp "mode reader\n") -;; 200 secnews.netscape.com Netscape-Collabra/3.52 03615 NNRP ready ... -;; nil -;; (process-send-string tmp "quit\n") -;; 205 -;; nil - -;; To use this package as a replacement for ssl.el by William M. Perry -;; <wmperry@cs.indiana.edu>, you need to evaluate the following: -;; -;; (defalias 'open-ssl-stream 'open-tls-stream) - -;;; Code: - -(require 'gnutls) - -(autoload 'format-spec "format-spec") -(autoload 'format-spec-make "format-spec") - -(defgroup tls nil - "Transport Layer Security (TLS) parameters." - :group 'comm) - -(defcustom tls-end-of-info - (concat - "\\(" - ;; `openssl s_client' regexp. See ssl/ssl_txt.c lines 219-220. - ;; According to apps/s_client.c line 1515 `---' is always the last - ;; line that is printed by s_client before the real data. - "^ Verify return code: .+\n---\n\\|" - ;; `gnutls' regexp. See src/cli.c lines 721-. - "^- Simple Client Mode:\n" - "\\(\n\\|" ; ignore blank lines - ;; According to GnuTLS v2.1.5 src/cli.c lines 640-650 and 705-715 - ;; in `main' the handshake will start after this message. If the - ;; handshake fails, the programs will abort. - "^\\*\\*\\* Starting TLS handshake\n\\)*" - "\\)") - "Regexp matching end of TLS client informational messages. -Client data stream begins after the last character this matches. -The default matches the output of \"gnutls-cli\" (version 2.0.1)." - :version "22.2" - :type 'regexp - :group 'tls) - -(defcustom tls-program - '("gnutls-cli --x509cafile %t -p %p %h" - "gnutls-cli --x509cafile %t -p %p %h --protocols ssl3") - "List of strings containing commands to start TLS stream to a host. -Each entry in the list is tried until a connection is successful. -%h is replaced with the server hostname, %p with the port to -connect to, and %t with a file name containing trusted certificates. -The program should read input on stdin and write output to stdout. - -See `tls-checktrust' on how to check trusted root certs. - -Also see `tls-success' for what the program should output after -successful negotiation." - :type - '(choice - (const :tag "Default list of commands" - ("gnutls-cli --x509cafile %t -p %p %h" - "gnutls-cli --x509cafile %t -p %p %h --protocols ssl3")) - (list :tag "Choose commands" - :value - ("gnutls-cli --x509cafile %t -p %p %h" - "gnutls-cli --x509cafile %t -p %p %h --protocols ssl3") - (set :inline t - ;; FIXME: add brief `:tag "..."' descriptions. - ;; (repeat :inline t :tag "Other" (string)) - ;; No trust check: - (const "gnutls-cli --insecure -p %p %h") - (const "gnutls-cli --insecure -p %p %h --protocols ssl3")) - (repeat :inline t :tag "Other" (string))) - (list :tag "List of commands" - (repeat :tag "Command" (string)))) - :version "26.1" ; remove s_client - :group 'tls) - -(defcustom tls-process-connection-type nil - "Value for `process-connection-type' to use when starting TLS process." - :version "22.1" - :type 'boolean - :group 'tls) - -(defcustom tls-success "- Handshake was completed\\|SSL handshake has read " - "Regular expression indicating completed TLS handshakes. -The default is what GnuTLS's \"gnutls-cli\" outputs." -;; or OpenSSL's \"openssl s_client\" - :version "22.1" - :type 'regexp - :group 'tls) - -(defcustom tls-checktrust nil - "Indicate if certificates should be checked against trusted root certs. -If this is `ask', the user can decide whether to accept an -untrusted certificate. You may have to adapt `tls-program' in -order to make this feature work properly, i.e., to ensure that -the external program knows about the root certificates you -consider trustworthy, e.g.: - -\(setq tls-program - \\='(\"gnutls-cli --x509cafile /etc/ssl/certs/ca-certificates.crt -p %p %h\" - \"gnutls-cli --x509cafile /etc/ssl/certs/ca-certificates.crt -p %p %h --protocols ssl3\"))" - :type '(choice (const :tag "Always" t) - (const :tag "Never" nil) - (const :tag "Ask" ask)) - :version "23.1" ;; No Gnus - :group 'tls) - -(defcustom tls-untrusted - "- Peer's certificate is NOT trusted\\|Verify return code: \\([^0] \\|.[^ ]\\)" - "Regular expression indicating failure of TLS certificate verification. -The default is what GnuTLS's \"gnutls-cli\" returns in the event of -unsuccessful verification." -;; or OpenSSL's \"openssl s_client\" - :type 'regexp - :version "23.1" ;; No Gnus - :group 'tls) - -(defcustom tls-hostmismatch - "# The hostname in the certificate does NOT match" - "Regular expression indicating a host name mismatch in certificate. -When the host name specified in the certificate doesn't match the -name of the host you are connecting to, gnutls-cli issues a -warning to this effect. There is no such feature in openssl. Set -this to nil if you want to ignore host name mismatches." - :type 'regexp - :version "23.1" ;; No Gnus - :group 'tls) - -(defcustom tls-certtool-program "certtool" - "Name of GnuTLS certtool. -Used by `tls-certificate-information'." - :version "22.1" - :type 'string - :group 'tls) - -(defalias 'tls-format-message - (if (fboundp 'format-message) 'format-message - ;; for Emacs < 25, and XEmacs, don't worry about quote translation. - 'format)) - -(defun tls-certificate-information (der) - "Parse X.509 certificate in DER format into an assoc list." - (let ((certificate (concat "-----BEGIN CERTIFICATE-----\n" - (base64-encode-string der) - "\n-----END CERTIFICATE-----\n")) - (exit-code 0)) - (with-current-buffer (get-buffer-create " *certtool*") - (erase-buffer) - (insert certificate) - (setq exit-code (condition-case () - (call-process-region (point-min) (point-max) - tls-certtool-program - t (list (current-buffer) nil) t - "--certificate-info") - (error -1))) - (if (/= exit-code 0) - nil - (let ((vals nil)) - (goto-char (point-min)) - (while (re-search-forward "^\\([^:]+\\): \\(.*\\)" nil t) - (push (cons (match-string 1) (match-string 2)) vals)) - (nreverse vals)))))) - -(defun open-tls-stream (name buffer host port) - "Open a TLS connection for a port to a host. -Returns a subprocess-object to represent the connection. -Input and output work as for subprocesses; `delete-process' closes it. -Args are NAME BUFFER HOST PORT. -NAME is name for process. It is modified if necessary to make it unique. -BUFFER is the buffer (or buffer name) to associate with the process. - Process output goes at end of that buffer, unless you specify - a filter function to handle the output. - BUFFER may be also nil, meaning that this process is not associated - with any buffer -Third arg is name of the host to connect to, or its IP address. -Fourth arg PORT is an integer specifying a port to connect to." - (let ((cmds tls-program) - (use-temp-buffer (null buffer)) - process cmd done) - (if use-temp-buffer - (setq buffer (generate-new-buffer " TLS")) - ;; BUFFER is a string but does not exist as a buffer object. - (unless (and (get-buffer buffer) - (buffer-name (get-buffer buffer))) - (generate-new-buffer buffer))) - (with-current-buffer buffer - (message "Opening TLS connection to `%s'..." host) - (while (and (not done) (setq cmd (pop cmds))) - (let ((process-connection-type tls-process-connection-type) - (formatted-cmd - (format-spec - cmd - (format-spec-make - ?t (car (gnutls-trustfiles)) - ?h host - ?p (if (integerp port) - (int-to-string port) - port))))) - (message "Opening TLS connection with `%s'..." formatted-cmd) - (setq process (start-process - name buffer shell-file-name shell-command-switch - formatted-cmd)) - (while (and process - (memq (process-status process) '(open run)) - (progn - (goto-char (point-min)) - (not (setq done (re-search-forward - tls-success nil t))))) - (unless (accept-process-output process 1) - (sit-for 1))) - (message "Opening TLS connection with `%s'...%s" formatted-cmd - (if done "done" "failed")) - (if (not done) - (delete-process process) - ;; advance point to after all informational messages that - ;; `openssl s_client' and `gnutls' print - (let ((start-of-data nil)) - (while - (not (setq start-of-data - ;; the string matching `tls-end-of-info' - ;; might come in separate chunks from - ;; `accept-process-output', so start the - ;; search where `tls-success' ended - (save-excursion - (if (re-search-forward tls-end-of-info nil t) - (match-end 0))))) - (accept-process-output process 1)) - (if start-of-data - ;; move point to start of client data - (goto-char start-of-data))) - (setq done process)))) - (when (and done - (or - (and tls-checktrust - (save-excursion - (goto-char (point-min)) - (re-search-forward tls-untrusted nil t)) - (or - (and (not (eq tls-checktrust 'ask)) - (message "The certificate presented by `%s' is \ -NOT trusted." host)) - (not (yes-or-no-p - (tls-format-message "\ -The certificate presented by `%s' is NOT trusted. Accept anyway? " host))))) - (and tls-hostmismatch - (save-excursion - (goto-char (point-min)) - (re-search-forward tls-hostmismatch nil t)) - (not (yes-or-no-p - (format "Host name in certificate doesn't \ -match `%s'. Connect anyway? " host)))))) - (setq done nil) - (delete-process process)) - ;; Delete all the informational messages that could confuse - ;; future uses of `buffer'. - (delete-region (point-min) (point))) - (message "Opening TLS connection to `%s'...%s" - host (if done "done" "failed")) - (when use-temp-buffer - (if done (set-process-buffer process nil)) - (kill-buffer buffer)) - done)) - -(provide 'tls) - -;;; tls.el ends here diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index b3aa7ca1bab..fb84aa11085 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -56,7 +56,7 @@ It is used for TCP/IP devices." ;;;###tramp-autoload (defcustom tramp-adb-prompt - "^\\(?:[[:digit:]]*|?\\)?\\(?:[[:alnum:]\e;[]*@?[[:alnum:]]*[^#\\$]*\\)?[#\\$][[:space:]]" + "^[[:digit:]]*|?[[:alnum:]\e;[]*@?[[:alnum:]]*[^#\\$]*[#\\$][[:space:]]" "Regexp used as prompt in almquist shell." :type 'string :version "24.4" @@ -68,7 +68,7 @@ It is used for TCP/IP devices." (defconst tramp-adb-ls-toolbox-regexp (concat - "^[[:space:]]*\\([-[:alpha:]]+\\)" ; \1 permissions + "^[[:space:]]*\\([-.[:alpha:]]+\\)" ; \1 permissions "\\(?:[[:space:]]+[[:digit:]]+\\)?" ; links (Android 7/toybox) "[[:space:]]*\\([^[:space:]]+\\)" ; \2 username "[[:space:]]+\\([^[:space:]]+\\)" ; \3 group @@ -78,22 +78,20 @@ It is used for TCP/IP devices." "Regexp for ls output.") ;;;###tramp-autoload -(add-to-list 'tramp-methods - `(,tramp-adb-method - (tramp-tmpdir "/data/local/tmp") - (tramp-default-port 5555))) +(tramp--with-startup + (add-to-list 'tramp-methods + `(,tramp-adb-method + (tramp-tmpdir "/data/local/tmp") + (tramp-default-port 5555))) -;;;###tramp-autoload -(add-to-list 'tramp-default-host-alist `(,tramp-adb-method nil "")) + (add-to-list 'tramp-default-host-alist `(,tramp-adb-method nil "")) -;;;###tramp-autoload -(eval-after-load 'tramp - '(tramp-set-completion-function - tramp-adb-method '((tramp-adb-parse-device-names "")))) + (tramp-set-completion-function + tramp-adb-method '((tramp-adb-parse-device-names "")))) ;;;###tramp-autoload (defconst tramp-adb-file-name-handler-alist - '((access-file . ignore) + '((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' performed by default handler. @@ -107,11 +105,12 @@ It is used for TCP/IP devices." . tramp-adb-handle-directory-files-and-attributes) (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) - (expand-file-name . tramp-adb-handle-expand-file-name) + (exec-path . tramp-adb-handle-exec-path) + (expand-file-name . tramp-handle-expand-file-name) (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . ignore) (file-attributes . tramp-adb-handle-file-attributes) - (file-directory-p . tramp-adb-handle-file-directory-p) + (file-directory-p . tramp-handle-file-directory-p) (file-equal-p . tramp-handle-file-equal-p) ;; FIXME: This is too sloppy. (file-executable-p . tramp-handle-file-exists-p) @@ -140,7 +139,6 @@ It is used for TCP/IP devices." (file-truename . tramp-adb-handle-file-truename) (file-writable-p . tramp-adb-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) - ;; `find-file-noselect' performed by default handler. ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) @@ -149,6 +147,7 @@ It is used for TCP/IP devices." (make-directory . tramp-adb-handle-make-directory) (make-directory-internal . ignore) (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) (process-file . tramp-adb-handle-process-file) (rename-file . tramp-adb-handle-rename-file) @@ -157,10 +156,11 @@ It is used for TCP/IP devices." (set-file-selinux-context . ignore) (set-file-times . tramp-adb-handle-set-file-times) (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) - (shell-command . tramp-adb-handle-shell-command) - (start-file-process . tramp-adb-handle-start-file-process) + (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-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) @@ -172,8 +172,9 @@ It is used for TCP/IP devices." ;;;###tramp-autoload (defsubst tramp-adb-file-name-p (filename) "Check if it's a filename for ADB." - (let ((v (tramp-dissect-file-name filename))) - (string= (tramp-file-name-method v) tramp-adb-method))) + (and (tramp-tramp-file-p filename) + (string= (tramp-file-name-method (tramp-dissect-file-name filename)) + tramp-adb-method))) ;;;###tramp-autoload (defun tramp-adb-file-name-handler (operation &rest args) @@ -186,72 +187,21 @@ pass to the OPERATION." (tramp-run-real-handler operation args)))) ;;;###tramp-autoload -(tramp-register-foreign-file-name-handler - 'tramp-adb-file-name-p 'tramp-adb-file-name-handler) +(tramp--with-startup + (tramp-register-foreign-file-name-handler + #'tramp-adb-file-name-p #'tramp-adb-file-name-handler)) ;;;###tramp-autoload (defun tramp-adb-parse-device-names (_ignore) "Return a list of (nil host) tuples allowed to access." - (with-timeout (10) - (with-temp-buffer - ;; `call-process' does not react on timer under MS Windows. - ;; That's why we use `start-process'. - (let ((p (start-process - tramp-adb-program (current-buffer) tramp-adb-program "devices")) - (v (make-tramp-file-name - :method tramp-adb-method :user tramp-current-user - :host tramp-current-host)) - result) - (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (process-put p 'adjust-window-size-function 'ignore) - (set-process-query-on-exit-flag p nil) - (while (process-live-p p) - (accept-process-output p 0.1)) - (accept-process-output p 0.1) - (tramp-message v 6 "\n%s" (buffer-string)) - (goto-char (point-min)) - (while (search-forward-regexp "^\\(\\S-+\\)[[:space:]]+device$" nil t) - (push (list nil (match-string 1)) result)) - - ;; Replace ":" by "#". - (mapc - (lambda (elt) - (setcar - (cdr elt) - (replace-regexp-in-string - ":" tramp-prefix-port-format (car (cdr elt))))) - result) - result)))) - -(defun tramp-adb-handle-expand-file-name (name &optional dir) - "Like `expand-file-name' for Tramp files." - ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". - (setq dir (or dir default-directory "/")) - ;; Unless NAME is absolute, concat DIR and NAME. - (unless (file-name-absolute-p name) - (setq name (concat (file-name-as-directory 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)) - ;; Dissect NAME. - (with-parsed-tramp-file-name name nil - (unless (tramp-run-real-handler 'file-name-absolute-p (list localname)) - (setq localname (concat "/" localname))) - ;; 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 - method user domain host port - (tramp-drop-volume-letter - (tramp-run-real-handler - 'expand-file-name (list localname)))))))) - -(defun tramp-adb-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - (eq (tramp-compat-file-attribute-type - (file-attributes (file-truename filename))) - t)) + (delq nil + (mapcar + (lambda (line) + (when (string-match "^\\(\\S-+\\)[[:space:]]+device$" line) + ;; Replace ":" by "#". + `(nil ,(replace-regexp-in-string + ":" tramp-prefix-port-format (match-string 1 line))))) + (tramp-process-lines nil tramp-adb-program "devices")))) (defun tramp-adb-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." @@ -264,18 +214,19 @@ pass to the OPERATION." (goto-char (point-min)) (forward-line) (when (looking-at - (concat "[[:space:]]*[^[:space:]]+" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)")) + (eval-when-compile + (concat "[[:space:]]*[^[:space:]]+" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)"))) ;; The values are given as 1k numbers, so we must change ;; them to number of bytes. - (list (* 1024 (string-to-number (concat (match-string 1) "e0"))) + (list (* 1024 (string-to-number (match-string 1))) ;; The second value is the used size. We need the ;; free size. - (* 1024 (- (string-to-number (concat (match-string 1) "e0")) - (string-to-number (concat (match-string 2) "e0")))) - (* 1024 (string-to-number (concat (match-string 3) "e0"))))))))) + (* 1024 (- (string-to-number (match-string 1)) + (string-to-number (match-string 2)))) + (* 1024 (string-to-number (match-string 3))))))))) ;; This is derived from `tramp-sh-handle-file-truename'. Maybe the ;; code could be shared? @@ -284,10 +235,10 @@ pass to the OPERATION." ;; Preserve trailing "/". (funcall (if (string-equal (file-name-nondirectory filename) "") - 'file-name-as-directory 'identity) + #'file-name-as-directory #'identity) (with-parsed-tramp-file-name (expand-file-name filename) nil (tramp-make-tramp-file-name - method user domain host port + v (with-tramp-file-property v localname "file-truename" (let ((result nil) ; result steps in reverse order (quoted (tramp-compat-file-name-quoted-p localname))) @@ -309,19 +260,15 @@ pass to the OPERATION." (setq thisstep (pop steps)) (tramp-message v 5 "Check %s" - (mapconcat 'identity - (append '("") (reverse result) (list thisstep)) - "/")) + (string-join + (append '("") (reverse result) (list thisstep)) "/")) (setq symlink-target (tramp-compat-file-attribute-type (file-attributes (tramp-make-tramp-file-name - method user domain host port - (mapconcat 'identity - (append '("") - (reverse result) - (list thisstep)) - "/"))))) + v + (string-join + (append '("") (reverse result) (list thisstep)) "/"))))) (cond ((string= "." thisstep) (tramp-message v 5 "Ignoring step `.'")) ((string= ".." thisstep) @@ -356,9 +303,9 @@ pass to the OPERATION." ;; Combine list to form string. (setq result (if result - (mapconcat 'identity (cons "" result) "/") + (string-join (cons "" result) "/") "/")) - (when (and is-dir (or (string= "" result) + (when (and is-dir (or (string-empty-p result) (not (string= (substring result -1) "/")))) (setq result (concat result "/")))) @@ -418,9 +365,9 @@ pass to the OPERATION." ;; no way to handle numeric ids in Androids ash (if (eq id-format 'integer) 0 uid) (if (eq id-format 'integer) 0 gid) - '(0 0) ; atime + tramp-time-dont-know ; atime (date-to-time date) ; mtime - '(0 0) ; ctime + tramp-time-dont-know ; ctime size mod-string ;; fake @@ -469,18 +416,24 @@ pass to the OPERATION." (sort result (lambda (x y) (string< (car x) (car y)))))) (delq nil (mapcar (lambda (x) - (if (or (not match) (string-match match (car x))) + (if (or (not match) (string-match-p match (car x))) x)) result))))))))) (defun tramp-adb-get-ls-command (vec) - "Determine `ls' command at its arguments." + "Determine `ls' command and its arguments." (with-tramp-connection-property vec "ls" (tramp-message vec 5 "Finding a suitable `ls' command") (cond + ;; Support Android derived systems where "ls" command is provided + ;; by GNU Coreutils. Force "ls" to print one column and set + ;; time-style to imitate other "ls" flavors. + ((tramp-adb-send-command-and-check + vec "ls --time-style=long-iso /dev/null") + "ls -1 --time-style=long-iso") ;; Can't disable coloring explicitly for toybox ls command. We - ;; must force "ls" to print just one column. - ((tramp-adb-send-command-and-check vec "toybox") "env COLUMNS=1 ls") + ;; also must force "ls" to print just one column. + ((tramp-adb-send-command-and-check vec "toybox") "ls -1") ;; On CyanogenMod based system BusyBox is used and "ls" output ;; coloring is enabled by default. So we try to disable it when ;; possible. @@ -492,15 +445,15 @@ pass to the OPERATION." "Almquist shell can't handle multiple arguments. Convert (\"-al\") to (\"-a\" \"-l\"). Remove arguments like \"--dired\"." (split-string - (apply 'concat + (apply #'concat (mapcar (lambda (s) (replace-regexp-in-string - "\\(.\\)" " -\\1" (replace-regexp-in-string "^-" "" s))) + "\\(.\\)" " -\\1" (replace-regexp-in-string "^-" "" s))) ;; FIXME: Warning about removed switches (long and non-dash). (delq nil (mapcar (lambda (s) - (and (not (string-match "\\(^--\\|^[^-]\\)" s)) s)) + (and (not (string-match-p "\\(^--\\|^[^-]\\)" s)) s)) switches)))))) (defun tramp-adb-sh-fix-ls-output (&optional sort-by-time) @@ -515,7 +468,7 @@ Emacs dired can't find files." "[[:space:]]\\([[:space:]][0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9][[:space:]]\\)" nil t) (replace-match "0\\1" "\\1" nil) ;; Insert missing "/". - (when (looking-at "[0-9][0-9]:[0-9][0-9][[:space:]]+$") + (when (looking-at-p "[0-9][0-9]:[0-9][0-9][[:space:]]+$") (end-of-line) (insert "/"))) ;; Sort entries. @@ -524,10 +477,10 @@ Emacs dired can't find files." (sort lines (if sort-by-time - 'tramp-adb-ls-output-time-less-p - 'tramp-adb-ls-output-name-less-p)))) + #'tramp-adb-ls-output-time-less-p + #'tramp-adb-ls-output-name-less-p)))) (delete-region (point-min) (point-max)) - (insert " " (mapconcat 'identity sorted-lines "\n "))) + (insert " " (string-join sorted-lines "\n "))) ;; Add final newline. (goto-char (point-max)) (unless (bolp) (insert "\n")))) @@ -536,9 +489,9 @@ Emacs dired can't find files." "Sort \"ls\" output by time, descending." (let (time-a time-b) (string-match tramp-adb-ls-date-regexp a) - (setq time-a (apply 'encode-time (parse-time-string (match-string 0 a)))) + (setq time-a (apply #'encode-time (parse-time-string (match-string 0 a)))) (string-match tramp-adb-ls-date-regexp b) - (setq time-b (apply 'encode-time (parse-time-string (match-string 0 b)))) + (setq time-b (apply #'encode-time (parse-time-string (match-string 0 b)))) (time-less-p time-b time-a))) (defun tramp-adb-ls-output-name-less-p (a b) @@ -557,8 +510,8 @@ Emacs dired can't find files." (let ((par (expand-file-name ".." dir))) (unless (file-directory-p par) (make-directory par parents)))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (unless (or (tramp-adb-send-command-and-check v (format "mkdir %s" (tramp-shell-quote-argument localname))) (and parents (file-directory-p dir))) @@ -568,11 +521,11 @@ Emacs dired can't find files." "Like `delete-directory' for Tramp files." (setq directory (expand-file-name directory)) (with-parsed-tramp-file-name (file-truename directory) nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname)) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname)) (with-parsed-tramp-file-name directory nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (tramp-adb-barf-unless-okay v (format "%s %s" (if recursive "rm -r" "rmdir") @@ -583,8 +536,8 @@ Emacs dired can't find files." "Like `delete-file' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (tramp-adb-barf-unless-okay v (format "rm %s" (tramp-shell-quote-argument localname)) "Couldn't delete %s" filename))) @@ -595,28 +548,27 @@ Emacs dired can't find files." filename (with-parsed-tramp-file-name (expand-file-name directory) nil (with-tramp-file-property v localname "file-name-all-completions" - (save-match-data - (tramp-adb-send-command - v (format "%s -a %s" - (tramp-adb-get-ls-command v) - (tramp-shell-quote-argument localname))) - (mapcar - (lambda (f) - (if (file-directory-p (expand-file-name f directory)) - (file-name-as-directory f) - f)) - (with-current-buffer (tramp-get-buffer v) - (delete-dups - (append - ;; In older Android versions, "." and ".." are not - ;; included. In newer versions (toybox, since Android - ;; 6) they are. We fix this by `delete-dups'. - '("." "..") - (delq - nil - (mapcar - (lambda (l) (and (not (string-match "^[[:space:]]*$" l)) l)) - (split-string (buffer-string) "\n")))))))))))) + (tramp-adb-send-command + v (format "%s -a %s" + (tramp-adb-get-ls-command v) + (tramp-shell-quote-argument localname))) + (mapcar + (lambda (f) + (if (file-directory-p (expand-file-name f directory)) + (file-name-as-directory f) + f)) + (with-current-buffer (tramp-get-buffer v) + (delete-dups + (append + ;; In older Android versions, "." and ".." are not + ;; included. In newer versions (toybox, since Android 6) + ;; they are. We fix this by `delete-dups'. + '("." "..") + (delq + nil + (mapcar + (lambda (l) (and (not (string-match-p "^[[:space:]]*$" l)) l)) + (split-string (buffer-string) "\n"))))))))))) (defun tramp-adb-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." @@ -635,13 +587,11 @@ Emacs dired can't find files." (ignore-errors (delete-file tmpfile)) (tramp-error v 'file-error "Cannot make local copy of file `%s'" filename)) - (set-file-modes - tmpfile - (logior (or (file-modes filename) 0) (string-to-number "0400" 8)))) + (set-file-modes tmpfile (logior (or (file-modes filename) 0) #o0400))) tmpfile))) (defun tramp-adb-handle-file-writable-p (filename) - "Like `tramp-sh-handle-file-writable-p'. + "Like `file-writable-p' for Tramp files. But handle the case, if the \"test\" command is not available." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-writable-p" @@ -677,17 +627,15 @@ But handle the case, if the \"test\" command is not available." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (let* ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok) - (set-file-modes - tmpfile - (logior (or (file-modes tmpfile) 0) (string-to-number "0600" 8)))) + (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 (list start end tmpfile append 'no-message lockname)) (with-tramp-progress-reporter v 3 (format-message "Moving tmp file `%s' to `%s'" tmpfile filename) @@ -717,23 +665,35 @@ But handle the case, if the \"test\" command is not available." (defun tramp-adb-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (tramp-adb-send-command-and-check v (format "chmod %o %s" mode localname)))) (defun tramp-adb-handle-set-file-times (filename &optional time) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) - (let ((time (if (or (null time) (equal time '(0 0))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (let ((time (if (or (null time) + (tramp-compat-time-equal-p time tramp-time-doesnt-exist) + (tramp-compat-time-equal-p time tramp-time-dont-know)) (current-time) - time))) + time)) + (quoted-name (tramp-shell-quote-argument localname))) + ;; Older versions of toybox 'touch' mishandle nanoseconds and/or + ;; trailing "Z", so fall back on plain seconds if nanoseconds+Z + ;; fails. Also, fall back on old POSIX 'touch -t' if 'touch -d' + ;; (introduced in POSIX.1-2008) fails. (tramp-adb-send-command-and-check - ;; Use shell arithmetic because of Emacs integer size limit. - v (format "touch -t $(( %d * 65536 + %d )) %s" - (car time) (cadr time) - (tramp-shell-quote-argument localname)))))) + v (format (concat "touch -d %s %s 2>/dev/null || " + "touch -d %s %s 2>/dev/null || " + "touch -t %s %s") + (format-time-string "%Y-%m-%dT%H:%M:%S.%NZ" time t) + quoted-name + (format-time-string "%Y-%m-%dT%H:%M:%S" time t) + quoted-name + (format-time-string "%Y%m%d%H%M.%S" time t) + quoted-name))))) (defun tramp-adb-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -749,20 +709,21 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname))) (with-parsed-tramp-file-name (if t1 filename newname) nil + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + (with-tramp-progress-reporter v 0 (format "Copying %s to %s" filename newname) - (if (and t1 t2 (tramp-equal-remote filename newname)) - (let ((l1 (file-remote-p filename 'localname)) - (l2 (file-remote-p newname 'localname))) - (when (and (not ok-if-already-exists) - (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) + (let ((l1 (tramp-compat-file-local-name filename)) + (l2 (tramp-compat-file-local-name newname))) ;; We must also flush the cache of the directory, ;; because `file-attributes' reads the values from ;; there. - (tramp-flush-file-property v (file-name-directory l2)) - (tramp-flush-file-property v l2) + (tramp-flush-file-properties v (file-name-directory l2)) + (tramp-flush-file-properties v l2) ;; Short track. (tramp-adb-barf-unless-okay v (format @@ -796,8 +757,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; We must also flush the cache of the directory, ;; because `file-attributes' reads the values from ;; there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties + v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (when (tramp-adb-execute-adb-command v "push" (tramp-compat-file-name-unquote filename) @@ -827,23 +789,24 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname))) (with-parsed-tramp-file-name (if t1 filename newname) nil + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + (with-tramp-progress-reporter v 0 (format "Renaming %s to %s" filename newname) - (if (and t1 t2 (tramp-equal-remote filename newname) (not (file-directory-p filename))) - (let ((l1 (file-remote-p filename 'localname)) - (l2 (file-remote-p newname 'localname))) - (when (and (not ok-if-already-exists) - (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) + (let ((l1 (tramp-compat-file-local-name filename)) + (l2 (tramp-compat-file-local-name newname))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory l1)) - (tramp-flush-file-property v l1) - (tramp-flush-file-property v (file-name-directory l2)) - (tramp-flush-file-property v l2) + (tramp-flush-file-properties v (file-name-directory l1)) + (tramp-flush-file-properties v l1) + (tramp-flush-file-properties v (file-name-directory l2)) + (tramp-flush-file-properties v l2) ;; Short track. (tramp-adb-barf-unless-okay v (format @@ -867,7 +830,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (with-parsed-tramp-file-name default-directory nil (let (command input tmpinput stderr tmpstderr outbuf ret) ;; Compute command. - (setq command (mapconcat 'tramp-shell-quote-argument + (setq command (mapconcat #'tramp-shell-quote-argument (cons program args) " ")) ;; Determine input. (if (null infile) @@ -878,8 +841,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq input (with-parsed-tramp-file-name infile nil localname)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) - tmpinput (tramp-make-tramp-file-name - method user domain host port input)) + tmpinput (tramp-make-tramp-file-name v input)) (copy-file infile tmpinput t))) (when input (setq command (format "%s <%s" command input))) @@ -912,8 +874,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; stderr must be copied to remote host. The temporary ;; file must be deleted after execution. (setq stderr (tramp-make-tramp-temp-file v) - tmpstderr (tramp-make-tramp-file-name - method user domain host port stderr)))) + tmpstderr (tramp-make-tramp-file-name v stderr)))) ;; stderr to be discarded. ((null (cadr destination)) (setq stderr "/dev/null")))) @@ -957,167 +918,143 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when tmpinput (delete-file tmpinput)) (unless process-file-side-effects - (tramp-flush-directory-property v "")) + (tramp-flush-directory-properties v "")) ;; Return exit status. (if (equal ret -1) (keyboard-quit) ret)))) -(defun tramp-adb-handle-shell-command - (command &optional output-buffer error-buffer) - "Like `shell-command' for Tramp files." - (let* ((asynchronous (string-match "[ \t]*&[ \t]*\\'" command)) - ;; We cannot use `shell-file-name' and `shell-command-switch', - ;; they are variables of the local host. - (args (list "sh" "-c" (substring command 0 asynchronous))) - current-buffer-p - (output-buffer - (cond - ((bufferp output-buffer) output-buffer) - ((stringp output-buffer) (get-buffer-create output-buffer)) - (output-buffer - (setq current-buffer-p t) - (current-buffer)) - (t (get-buffer-create - (if asynchronous - "*Async Shell Command*" - "*Shell Command Output*"))))) - (error-buffer - (cond - ((bufferp error-buffer) error-buffer) - ((stringp error-buffer) (get-buffer-create error-buffer)))) - (buffer - (if (and (not asynchronous) error-buffer) - (with-parsed-tramp-file-name default-directory nil - (list output-buffer (tramp-make-tramp-temp-file v))) - output-buffer)) - (p (get-buffer-process output-buffer))) - - ;; Check whether there is another process running. Tramp does not - ;; support 2 (asynchronous) processes in parallel. - (when p - (if (yes-or-no-p "A command is running. Kill it? ") - (ignore-errors (kill-process p)) - (tramp-compat-user-error p "Shell command in progress"))) - - (if current-buffer-p - (progn - (barf-if-buffer-read-only) - (push-mark nil t)) - (with-current-buffer output-buffer - (setq buffer-read-only nil) - (erase-buffer))) - - (if (and (not current-buffer-p) (integerp asynchronous)) - (prog1 - ;; Run the process. - (apply 'start-file-process "*Async Shell*" buffer args) - ;; Display output. - (pop-to-buffer output-buffer) - (setq mode-line-process '(":%s")) - (shell-mode)) - - (prog1 - ;; Run the process. - (apply 'process-file (car args) nil buffer nil (cdr args)) - ;; Insert error messages if they were separated. - (when (listp buffer) - (with-current-buffer error-buffer - (insert-file-contents (cadr buffer))) - (delete-file (cadr buffer))) - (if current-buffer-p - ;; This is like exchange-point-and-mark, but doesn't - ;; activate the mark. It is cleaner to avoid activation, - ;; even though the command loop would deactivate the mark - ;; because we inserted text. - (goto-char (prog1 (mark t) - (set-marker (mark-marker) (point) - (current-buffer)))) - ;; There's some output, display it. - (when (with-current-buffer output-buffer (> (point-max) (point-min))) - (display-message-or-buffer output-buffer))))))) - ;; 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. -(defun tramp-adb-handle-start-file-process (name buffer program &rest args) - "Like `start-file-process' for Tramp files." - (with-parsed-tramp-file-name default-directory nil - ;; When PROGRAM is nil, we should provide a tty. This is not - ;; possible here. - (unless (stringp program) - (tramp-error v 'file-error "PROGRAM must be a string")) - - (let* ((buffer - (if buffer - (get-buffer-create buffer) - ;; BUFFER can be nil. We use a temporary buffer. - (generate-new-buffer tramp-temp-buffer-name))) - (command - (format "cd %s; %s" - (tramp-shell-quote-argument localname) - (mapconcat 'tramp-shell-quote-argument - (cons program args) " "))) - (tramp-process-connection-type - (or (null program) tramp-process-connection-type)) - (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) - (name1 name) - (i 0) - ;; We do not want to run timers. - timer-list timer-idle-list) - - (while (get-process name1) - ;; NAME must be unique as process name. - (setq i (1+ i) - name1 (format "%s<%d>" name i))) - (setq name name1) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) - - (with-current-buffer (tramp-get-connection-buffer v) - (unwind-protect - ;; We catch this event. Otherwise, `start-process' could - ;; be called on the local host. - (save-excursion - (save-restriction - ;; Activate narrowing in order to save BUFFER - ;; contents. Clear also the modification time; - ;; otherwise we might be interrupted by - ;; `verify-visited-file-modtime'. - (let ((buffer-undo-list t) - (buffer-read-only nil) - (mark (point))) - (clear-visited-file-modtime) - (narrow-to-region (point-max) (point-max)) - ;; We call `tramp-adb-maybe-open-connection', in - ;; order to cleanup the prompt afterwards. - (tramp-adb-maybe-open-connection v) - (widen) - (delete-region mark (point)) - (narrow-to-region (point-max) (point-max)) - ;; Send the command. - (let ((tramp-adb-prompt (regexp-quote command))) - (tramp-adb-send-command v command)) - (let ((p (tramp-get-connection-process v))) - ;; Set query flag and process marker for this - ;; process. We ignore errors, because the process - ;; could have finished already. - (ignore-errors - (set-process-query-on-exit-flag p t) - (set-marker (process-mark p) (point))) - ;; Return process. - p)))) - - ;; Save exit. - (if (string-match tramp-temp-buffer-name (buffer-name)) - (ignore-errors - (set-process-buffer (tramp-get-connection-process v) nil) - (kill-buffer (current-buffer))) - (set-buffer-modified-p bmp)) - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil)))))) +(defun tramp-adb-handle-make-process (&rest args) + "Like `make-process' for Tramp files." + (when args + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let ((name (plist-get args :name)) + (buffer (plist-get args :buffer)) + (command (plist-get args :command)) + (coding (plist-get args :coding)) + (noquery (plist-get args :noquery)) + (connection-type (plist-get args :connection-type)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + (stderr (plist-get args :stderr))) + (unless (stringp name) + (signal 'wrong-type-argument (list #'stringp name))) + (unless (or (null buffer) (bufferp buffer) (stringp buffer)) + (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (consp command) + (signal 'wrong-type-argument (list #'consp command))) + (unless (or (null coding) + (and (symbolp coding) (memq coding coding-system-list)) + (and (consp coding) + (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))) + (signal 'wrong-type-argument (list #'symbolp connection-type))) + (unless (or (null filter) (functionp filter)) + (signal 'wrong-type-argument (list #'functionp filter))) + (unless (or (null sentinel) (functionp sentinel)) + (signal 'wrong-type-argument (list #'functionp sentinel))) + (unless (or (null stderr) (bufferp stderr) (stringp stderr)) + (signal 'wrong-type-argument (list #'stringp stderr))) + + (let* ((buffer + (if buffer + (get-buffer-create buffer) + ;; BUFFER can be nil. We use a temporary buffer. + (generate-new-buffer tramp-temp-buffer-name))) + (program (car command)) + (args (cdr command)) + (command + (format "cd %s && exec %s" + (tramp-shell-quote-argument localname) + (mapconcat #'tramp-shell-quote-argument + (cons program args) " "))) + (tramp-process-connection-type + (or (null program) tramp-process-connection-type)) + (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) + (name1 name) + (i 0)) + + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + (setq name name1) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) + + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + ;; We catch this event. Otherwise, `make-process' + ;; could be called on the local host. + (save-excursion + (save-restriction + ;; Activate narrowing in order to save BUFFER + ;; contents. Clear also the modification time; + ;; otherwise we might be interrupted by + ;; `verify-visited-file-modtime'. + (let ((buffer-undo-list t) + (inhibit-read-only t)) + (clear-visited-file-modtime) + (narrow-to-region (point-max) (point-max)) + ;; We call `tramp-adb-maybe-open-connection', in + ;; order to cleanup the prompt afterwards. + (tramp-adb-maybe-open-connection v) + (delete-region (point-min) (point-max)) + ;; Send the command. + (let* ((p (tramp-get-connection-process v))) + (tramp-adb-send-command v command nil t) ; nooutput + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + ;; Set query flag and process marker for this + ;; process. We ignore errors, because the + ;; process could have finished already. + (ignore-errors + (set-process-query-on-exit-flag p (null noquery)) + (set-marker (process-mark p) (point))) + ;; Read initial output. Remove the first line, + ;; which is the command echo. + (while + (progn + (goto-char (point-min)) + (not (re-search-forward "[\n]" nil t))) + (tramp-accept-process-output p 0)) + (delete-region (point-min) (point)) + ;; Return process. + p)))) + + ;; Save exit. + (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (ignore-errors + (set-process-buffer (tramp-get-connection-process v) nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp)) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer")))))))) + +(defun tramp-adb-handle-exec-path () + "Like `exec-path' for Tramp files." + (append + (with-parsed-tramp-file-name default-directory nil + (with-tramp-connection-property v "remote-path" + (tramp-adb-send-command v "echo \\\"$PATH\\\"") + (split-string + (with-current-buffer (tramp-get-connection-buffer v) + ;; Read the expression. + (goto-char (point-min)) + (read (current-buffer))) + ":" 'omit))) + ;; The equivalent to `exec-directory'. + `(,(tramp-compat-file-local-name default-directory)))) (defun tramp-adb-get-device (vec) "Return full host name from VEC to be used in shell execution. @@ -1126,11 +1063,11 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" ;; Sometimes this is called before there is a connection process ;; yet. In order to work with the connection cache, we flush all ;; unwanted entries first. - (tramp-flush-connection-property nil) + (tramp-flush-connection-properties nil) (with-tramp-connection-property (tramp-get-connection-process vec) "device" (let* ((host (tramp-file-name-host vec)) (port (tramp-file-name-port-or-default vec)) - (devices (mapcar 'cadr (tramp-adb-parse-device-names nil)))) + (devices (mapcar #'cadr (tramp-adb-parse-device-names nil)))) (replace-regexp-in-string tramp-prefix-port-format ":" (cond ((member host devices) host) @@ -1167,7 +1104,7 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" (prog1 (unless (zerop - (apply 'tramp-call-process vec tramp-adb-program nil t nil args)) + (apply #'tramp-call-process vec tramp-adb-program nil t nil args)) (buffer-string)) (tramp-message vec 6 "%s" (buffer-string))))) @@ -1179,24 +1116,27 @@ This happens for Android >= 4.0." ;; Connection functions -(defun tramp-adb-send-command (vec command) +(defun tramp-adb-send-command (vec command &optional neveropen nooutput) "Send the COMMAND to connection VEC." - (tramp-adb-maybe-open-connection vec) + (unless neveropen (tramp-adb-maybe-open-connection vec)) (tramp-message vec 6 "%s" command) (tramp-send-string vec command) - ;; fixme: Race condition - (tramp-adb-wait-for-output (tramp-get-connection-process vec)) - (with-current-buffer (tramp-get-connection-buffer vec) - (save-excursion - (goto-char (point-min)) - ;; We can't use stty to disable echo of command. - (delete-matching-lines (regexp-quote command)) - ;; When the local machine is W32, there are still trailing ^M. - ;; There must be a better solution by setting the correct coding - ;; system, but this requires changes in core Tramp. - (goto-char (point-min)) - (while (re-search-forward "\r+$" nil t) - (replace-match "" nil nil))))) + (unless nooutput + ;; FIXME: Race condition. + (tramp-adb-wait-for-output (tramp-get-connection-process vec)) + (with-current-buffer (tramp-get-connection-buffer vec) + (save-excursion + (goto-char (point-min)) + ;; We can't use stty to disable echo of command. stty is said + ;; to be added to toybox 0.7.6. busybox shall have it, but this + ;; isn't used any longer for Android. + (delete-matching-lines (regexp-quote command)) + ;; When the local machine is W32, there are still trailing ^M. + ;; There must be a better solution by setting the correct coding + ;; system, but this requires changes in core Tramp. + (goto-char (point-min)) + (while (re-search-forward "\r+$" nil t) + (replace-match "" nil nil)))))) (defun tramp-adb-send-command-and-check (vec command) "Run COMMAND and check its exit status. @@ -1215,51 +1155,43 @@ the exit status is not equal 0, and t otherwise." (skip-chars-forward "^ ") (prog1 (zerop (read (current-buffer))) - (let (buffer-read-only) + (let ((inhibit-read-only t)) (delete-region (match-beginning 0) (point-max)))))) (defun tramp-adb-barf-unless-okay (vec command fmt &rest args) "Run COMMAND, check exit status, throw error if exit status not okay. FMT and ARGS are passed to `error'." (unless (tramp-adb-send-command-and-check vec command) - (apply 'tramp-error vec 'file-error fmt args))) + (apply #'tramp-error vec 'file-error fmt args))) (defun tramp-adb-wait-for-output (proc &optional timeout) "Wait for output from remote command." (unless (buffer-live-p (process-buffer proc)) (delete-process proc) (tramp-error proc 'file-error "Process `%s' not available, try again" proc)) - (with-current-buffer (process-buffer proc) - (if (tramp-wait-for-regexp - proc timeout - (tramp-get-connection-property proc "prompt" tramp-adb-prompt)) - (let (buffer-read-only) - (goto-char (point-min)) - ;; ADB terminal sends "^H" sequences. - (when (re-search-forward "<\b+" (point-at-eol) t) - (forward-line 1) - (delete-region (point-min) (point))) - ;; Delete the prompt. - (goto-char (point-min)) - (when (re-search-forward - (tramp-get-connection-property proc "prompt" tramp-adb-prompt) - (point-at-eol) t) - (forward-line 1) - (delete-region (point-min) (point))) - (goto-char (point-max)) - (re-search-backward - (tramp-get-connection-property proc "prompt" tramp-adb-prompt) nil t) - (delete-region (point) (point-max))) - (if timeout + (let ((prompt (tramp-get-connection-property proc "prompt" tramp-adb-prompt))) + (with-current-buffer (process-buffer proc) + (if (tramp-wait-for-regexp proc timeout prompt) + (let ((inhibit-read-only t)) + (goto-char (point-min)) + ;; ADB terminal sends "^H" sequences. + (when (re-search-forward "<\b+" (point-at-eol) t) + (forward-line 1) + (delete-region (point-min) (point))) + ;; Delete the prompt. + (goto-char (point-min)) + (when (re-search-forward prompt (point-at-eol) t) + (forward-line 1) + (delete-region (point-min) (point))) + (goto-char (point-max)) + (re-search-backward prompt nil t) + (delete-region (point) (point-max))) + (if timeout + (tramp-error + proc 'file-error + "[[Remote prompt `%s' not found in %d secs]]" prompt timeout) (tramp-error - proc 'file-error - "[[Remote adb prompt `%s' not found in %d secs]]" - (tramp-get-connection-property proc "prompt" tramp-adb-prompt) - timeout) - (tramp-error - proc 'file-error - "[[Remote prompt `%s' not found]]" - (tramp-get-connection-property proc "prompt" tramp-adb-prompt)))))) + proc 'file-error "[[Remote prompt `%s' not found]]" prompt)))))) (defun tramp-adb-maybe-open-connection (vec) "Maybe open a connection VEC. @@ -1271,10 +1203,6 @@ connection if a previous connection has died for some reason." (user (tramp-file-name-user vec)) (device (tramp-adb-get-device vec))) - ;; Set variables for proper tracing in `tramp-adb-parse-device-names'. - (setq tramp-current-user (tramp-file-name-user vec) - tramp-current-host (tramp-file-name-host vec)) - ;; Maybe we know already that "su" is not supported. We cannot ;; use a connection property, because we have not checked yet ;; whether it is still the same device. @@ -1282,6 +1210,14 @@ connection if a previous connection has died for some reason." (tramp-error vec 'file-error "Cannot switch to user `%s'" user)) (unless (process-live-p p) + ;; During completion, don't reopen a new connection. We check + ;; this for the process related to `tramp-buffer-name'; + ;; otherwise `start-file-process' wouldn't run ever when + ;; `non-essential' is non-nil. + (when (and (tramp-completion-mode-p) + (null (get-process (tramp-buffer-name vec)))) + (throw 'non-essential 'non-essential)) + (save-match-data (when (and p (processp p)) (delete-process p)) (if (zerop (length device)) @@ -1294,18 +1230,24 @@ connection if a previous connection has died for some reason." (list "shell"))) (p (let ((default-directory (tramp-compat-temporary-file-directory))) - (apply 'start-process (tramp-get-connection-name vec) buf + (apply #'start-process (tramp-get-connection-name vec) buf tramp-adb-program args))) (prompt (md5 (concat (prin1-to-string process-environment) (current-time-string))))) (tramp-message - vec 6 "%s" (mapconcat 'identity (process-command p) " ")) - ;; Wait for initial prompt. + vec 6 "%s" (string-join (process-command p) " ")) + ;; Wait for initial prompt. On some devices, it needs an + ;; initial RET, in order to get it. + (sleep-for 0.1) + (tramp-send-string vec tramp-rsh-end-of-line) (tramp-adb-wait-for-output p 30) (unless (process-live-p p) - (tramp-error vec 'file-error "Terminated!")) - (tramp-set-connection-property p "vector" vec) - (process-put p 'adjust-window-size-function 'ignore) + (tramp-error vec 'file-error "Terminated!")) + + ;; Set sentinel and query flag. Initialize variables. + (set-process-sentinel p #'tramp-process-sentinel) + (process-put p 'vector vec) + (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) ;; Change prompt. @@ -1343,28 +1285,34 @@ connection if a previous connection has died for some reason." (tramp-adb-send-command vec (format "su %s" user)) (unless (tramp-adb-send-command-and-check vec nil) (delete-process p) - (tramp-set-file-property vec "" "su-command-p" nil) + (tramp-flush-file-property vec "" "su-command-p") (tramp-error vec 'file-error "Cannot switch to user `%s'" user))) - ;; Set "remote-path" connection property. This is needed - ;; for eshell. - (tramp-adb-send-command vec "echo \\\"$PATH\\\"") - (tramp-set-connection-property - vec "remote-path" - (split-string - (with-current-buffer (tramp-get-connection-buffer vec) - ;; Read the expression. - (goto-char (point-min)) - (read (current-buffer))) - ":" 'omit)) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec) ;; Mark it as connected. (tramp-set-connection-property p "connected" t))))))) +;; Default settings for connection-local variables. +(defconst tramp-adb-connection-local-default-profile + '((shell-file-name . "/system/bin/sh") + (shell-command-switch . "-c")) + "Default connection-local variables for remote adb connections.") + +;; `connection-local-set-profile-variables' and +;; `connection-local-set-profiles' exists since Emacs 26.1. +(with-eval-after-load 'shell + (tramp-compat-funcall + 'connection-local-set-profile-variables + 'tramp-adb-connection-local-default-profile + tramp-adb-connection-local-default-profile) + (tramp-compat-funcall + 'connection-local-set-profiles + `(:application tramp :protocol ,tramp-adb-method) + 'tramp-adb-connection-local-default-profile)) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-adb 'force))) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el new file mode 100644 index 00000000000..82fd327770b --- /dev/null +++ b/lisp/net/tramp-archive.el @@ -0,0 +1,667 @@ +;;; tramp-archive.el --- Tramp archive manager -*- lexical-binding:t -*- + +;; Copyright (C) 2017-2019 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Access functions for file archives. This is possible only on +;; machines which have installed the virtual file system for the Gnome +;; Desktop (GVFS). Internally, file archives are mounted via the GVFS +;; "archive" method. + +;; A file archive is a regular file of kind "/path/to/dir/file.EXT". +;; The extension ".EXT" identifies the type of the file archive. A +;; file inside a file archive, called archive file name, has the name +;; "/path/to/dir/file.EXT/dir/file". + +;; Most of the magic file name operations are implemented for archive +;; file names, exceptions are all operations which write into a file +;; archive, and process related operations. Therefore, functions like + +;; (copy-file "/path/to/dir/file.tar/dir/file" "/somewhere/else") + +;; work out of the box. This is also true for file name completion, +;; and for libraries like `dired' or `ediff', which accept archive +;; file names as well. + +;; File archives are identified by the file name extension ".EXT". +;; Since GVFS uses internally the library libarchive(3), all suffixes, +;; which are accepted by this library, work also for archive file +;; names. Accepted suffixes are listed in the constant +;; `tramp-archive-suffixes'. They are + +;; * ".7z" - 7-Zip archives +;; * ".apk" - Android package kits +;; * ".ar" - UNIX archiver formats +;; * ".cab", ".CAB" - Microsoft Windows cabinets +;; * ".cpio" - CPIO archives +;; * ".deb" - Debian packages +;; * ".depot" - HP-UX SD depots +;; * ".exe" - Self extracting Microsoft Windows EXE files +;; * ".iso" - ISO 9660 images +;; * ".jar" - Java archives +;; * ".lzh", ".LZH" - Microsoft Windows compressed LHA archives +;; * ".msu", ".MSU" - Microsoft Windows Update packages +;; * ".mtree" - BSD mtree format +;; * ".odb" ".odf" ".odg" ".odp" ".ods" ".odt" - OpenDocument formats +;; * ".pax" - Posix archives +;; * ".rar" - RAR archives +;; * ".rpm" - Red Hat packages +;; * ".shar" - Shell archives +;; * ".tar", ".tbz", ".tgz", ".tlz", ".txz" - (Compressed) tape archives +;; * ".warc" - Web archives +;; * ".xar" - macOS XAR archives +;; * ".xpi" - XPInstall Mozilla addons +;; * ".xps" - Open XML Paper Specification (OpenXPS) documents +;; * ".zip", ".ZIP" - ZIP archives + +;; File archives could also be compressed, identified by an additional +;; compression suffix. Valid compression suffixes are listed in the +;; constant `tramp-archive-compression-suffixes'. They are ".bz2", +;; ".gz", ".lrz", ".lz", ".lz4", ".lzma", ".lzo", ".uu", ".xz", ".Z", +;; and ".zst". A valid archive file name would be +;; "/path/to/dir/file.tar.gz/dir/file". Even several suffixes in a +;; row are possible, like "/path/to/dir/file.tar.gz.uu/dir/file". + +;; An archive file name could be a remote file name, as in +;; "/ftp:anonymous@ftp.gnu.org:/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL". +;; Since all file operations are mapped internally to GVFS operations, +;; remote file names supported by tramp-gvfs.el perform better, +;; because no local copy of the file archive must be downloaded first. +;; For example, "/sftp:user@host:..." performs better than the similar +;; "/scp:user@host:...". See the constant +;; `tramp-archive-all-gvfs-methods' for a complete list of +;; tramp-gvfs.el supported method names. + +;; If `url-handler-mode' is enabled, archives could be visited via +;; URLs, like "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL". +;; This allows complex file operations like + +;; (ediff-directories +;; "https://ftp.gnu.org/gnu/tramp/tramp-2.3.1.tar.gz/tramp-2.3.1" +;; "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/tramp-2.3.2" "") + +;; It is even possible to access file archives in file archives, as + +;; (find-file +;; "http://ftp.debian.org/debian/pool/main/c/coreutils/coreutils_8.28-1_amd64.deb/control.tar.gz/control") + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +;; Sometimes, compilation fails with "Variable binding depth exceeds +;; max-specpdl-size". +(eval-and-compile + (let ((max-specpdl-size (* 2 max-specpdl-size))) (require 'tramp-gvfs))) + +(autoload 'dired-uncache "dired") +(autoload 'url-tramp-convert-url-to-tramp "url-tramp") +(defvar url-handler-mode-hook) +(defvar url-handler-regexp) +(defvar url-tramp-protocols) + +;; We cannot check `tramp-gvfs-enabled' in loaddefs.el, because this +;; would load Tramp. So we make a cheaper check. +;;;###autoload +(defvar tramp-archive-enabled (featurep 'dbusbind) + "Non-nil when file archive support is available.") + +;; After loading tramp-gvfs.el, we know it better. +(setq tramp-archive-enabled tramp-gvfs-enabled) + +;; <https://github.com/libarchive/libarchive/wiki/LibarchiveFormats> +;; Note: "arc" and "zoo" are supported by `archive-mode', but they +;; don't work here. +;;;###autoload +(defconst tramp-archive-suffixes + ;; "cab", "lzh", "msu" and "zip" are included with lower and upper + ;; letters, because Microsoft Windows provides them often with + ;; capital letters. + '("7z" ;; 7-Zip archives. + "apk" ;; Android package kits. Not in libarchive testsuite. + "ar" ;; UNIX archiver formats. + "cab" "CAB" ;; Microsoft Windows cabinets. + "cpio" ;; CPIO archives. + "deb" ;; Debian packages. Not in libarchive testsuite. + "depot" ;; HP-UX SD depot. Not in libarchive testsuite. + "exe" ;; Self extracting Microsoft Windows EXE files. + "iso" ;; ISO 9660 images. + "jar" ;; Java archives. Not in libarchive testsuite. + "lzh" "LZH" ;; Microsoft Windows compressed LHA archives. + "msu" "MSU" ;; Microsoft Windows Update packages. Not in testsuite. + "mtree" ;; BSD mtree format. + "odb" "odf" "odg" "odp" "ods" "odt" ;; OpenDocument formats. Not in testsuite. + "pax" ;; Posix archives. + "rar" ;; RAR archives. + "rpm" ;; Red Hat packages. + "shar" ;; Shell archives. Not in libarchive testsuite. + "tar" "tbz" "tgz" "tlz" "txz" "tzst" ;; (Compressed) tape archives. + "warc" ;; Web archives. + "xar" ;; macOS XAR archives. Not in libarchive testsuite. + "xpi" ;; XPInstall Mozilla addons. Not in libarchive testsuite. + "xps" ;; Open XML Paper Specification (OpenXPS) documents. + "zip" "ZIP") ;; ZIP archives. + "List of suffixes which indicate a file archive. +It must be supported by libarchive(3).") + +;; <http://unix-memo.readthedocs.io/en/latest/vfs.html> +;; read and write: tar, cpio, pax , gzip , zip, bzip2, xz, lzip, lzma, ar, mtree, iso9660, compress. +;; read only: 7-Zip, mtree, xar, lha/lzh, rar, microsoft cab. + +;;;###autoload +(defconst tramp-archive-compression-suffixes + '("bz2" "gz" "lrz" "lz" "lz4" "lzma" "lzo" "uu" "xz" "Z" "zst") + "List of suffixes which indicate a compressed file. +It must be supported by libarchive(3).") + +;; The definition of `tramp-archive-file-name-regexp' contains calls +;; to `regexp-opt', which cannot be autoloaded while loading +;; loaddefs.el. So we use a macro, which is evaluated only when needed. +;;;###autoload +(progn (defmacro tramp-archive-autoload-file-name-regexp () + "Regular expression matching archive file names." + '(concat + "\\`" "\\(" ".+" "\\." + ;; Default suffixes ... + (regexp-opt tramp-archive-suffixes) + ;; ... with compression. + "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*" + "\\)" ;; \1 + "\\(" "/" ".*" "\\)" "\\'"))) ;; \2 + +;; In older Emacsen (prior 27.1), `tramp-archive-autoload-file-name-regexp' +;; is not autoloaded. So we cannot expect it to be known in +;; tramp-loaddefs.el. But it exists, when tramp-archive.el is loaded. +;;;###tramp-autoload +(defconst tramp-archive-file-name-regexp + (ignore-errors (tramp-archive-autoload-file-name-regexp)) + "Regular expression matching archive file names.") + +;;;###tramp-autoload +(defconst tramp-archive-method "archive" + "Method name for archives in GVFS.") + +(defconst tramp-archive-all-gvfs-methods + (cons tramp-archive-method + (let ((values (cdr (cadr (get 'tramp-gvfs-methods 'custom-type))))) + (setq values (mapcar #'last values) + values (mapcar #'car values)))) + "List of all methods `tramp-gvfs-methods' offers.") + + +;; New handlers should be added here. +;;;###tramp-autoload +(defconst tramp-archive-file-name-handler-alist + '((access-file . tramp-archive-handle-access-file) + (add-name-to-file . tramp-archive-handle-not-implemented) + ;; `byte-compiler-base-file-name' performed by default handler. + ;; `copy-directory' performed by default handler. + (copy-file . tramp-archive-handle-copy-file) + (delete-directory . tramp-archive-handle-not-implemented) + (delete-file . tramp-archive-handle-not-implemented) + ;; `diff-latest-backup-file' performed by default handler. + (directory-file-name . tramp-archive-handle-directory-file-name) + (directory-files . tramp-handle-directory-files) + (directory-files-and-attributes + . tramp-handle-directory-files-and-attributes) + (dired-compress-file . tramp-archive-handle-not-implemented) + (dired-uncache . tramp-archive-handle-dired-uncache) + (exec-path . ignore) + ;; `expand-file-name' performed by default handler. + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) + (file-acl . ignore) + (file-attributes . tramp-archive-handle-file-attributes) + (file-directory-p . tramp-handle-file-directory-p) + (file-equal-p . tramp-handle-file-equal-p) + (file-executable-p . tramp-archive-handle-file-executable-p) + (file-exists-p . tramp-handle-file-exists-p) + (file-in-directory-p . tramp-handle-file-in-directory-p) + (file-local-copy . tramp-archive-handle-file-local-copy) + (file-modes . tramp-handle-file-modes) + (file-name-all-completions . tramp-archive-handle-file-name-all-completions) + ;; `file-name-as-directory' performed by default handler. + (file-name-case-insensitive-p . ignore) + (file-name-completion . tramp-handle-file-name-completion) + ;; `file-name-directory' performed by default handler. + ;; `file-name-nondirectory' performed by default handler. + ;; `file-name-sans-versions' performed by default handler. + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) + (file-notify-add-watch . ignore) + (file-notify-rm-watch . ignore) + (file-notify-valid-p . ignore) + (file-ownership-preserved-p . ignore) + (file-readable-p . tramp-archive-handle-file-readable-p) + (file-regular-p . tramp-handle-file-regular-p) + ;; `file-remote-p' performed by default handler. + (file-selinux-context . tramp-handle-file-selinux-context) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-system-info . tramp-archive-handle-file-system-info) + (file-truename . tramp-archive-handle-file-truename) + (file-writable-p . ignore) + (find-backup-file-name . ignore) + ;; `get-file-buffer' performed by default handler. + (insert-directory . tramp-archive-handle-insert-directory) + (insert-file-contents . tramp-archive-handle-insert-file-contents) + (load . tramp-archive-handle-load) + (make-auto-save-file-name . ignore) + (make-directory . tramp-archive-handle-not-implemented) + (make-directory-internal . tramp-archive-handle-not-implemented) + (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-process . ignore) + (make-symbolic-link . tramp-archive-handle-not-implemented) + (process-file . ignore) + (rename-file . tramp-archive-handle-not-implemented) + (set-file-acl . ignore) + (set-file-modes . tramp-archive-handle-not-implemented) + (set-file-selinux-context . ignore) + (set-file-times . tramp-archive-handle-not-implemented) + (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) + (shell-command . tramp-archive-handle-not-implemented) + (start-file-process . tramp-archive-handle-not-implemented) + ;; `substitute-in-file-name' performed by default handler. + (temporary-file-directory . tramp-archive-handle-temporary-file-directory) + ;; `tramp-set-file-uid-gid' performed by default handler. + (unhandled-file-name-directory . ignore) + (vc-registered . ignore) + (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (write-region . tramp-archive-handle-not-implemented)) + "Alist of handler functions for file archive method. +Operations not mentioned here will be handled by the default Emacs primitives.") + +(defsubst tramp-archive-file-name-for-operation (operation &rest args) + "Like `tramp-file-name-for-operation', but for archive file name syntax." + (cl-letf (((symbol-function #'tramp-tramp-file-p) + #'tramp-archive-file-name-p)) + (apply #'tramp-file-name-for-operation operation args))) + +(defun tramp-archive-run-real-handler (operation args) + "Invoke normal file name handler for OPERATION. +First arg specifies the OPERATION, second arg is a list of arguments to +pass to the OPERATION." + (let* ((inhibit-file-name-handlers + `(tramp-archive-file-name-handler + . + ,(and (eq inhibit-file-name-operation operation) + inhibit-file-name-handlers))) + (inhibit-file-name-operation operation)) + (apply operation args))) + +;;;###tramp-autoload +(defun tramp-archive-file-name-handler (operation &rest args) + "Invoke the file archive related OPERATION. +First arg specifies the OPERATION, second arg is a list of arguments to +pass to the OPERATION." + (if (not tramp-archive-enabled) + ;; Unregister `tramp-archive-file-name-handler'. + (progn + (tramp-register-file-name-handlers) + (tramp-archive-run-real-handler operation args)) + + (let* ((filename (apply #'tramp-archive-file-name-for-operation + operation args)) + (archive (tramp-archive-file-name-archive filename))) + + ;; `filename' could be a quoted file name. Or the file + ;; archive could be a directory, see Bug#30293. + (if (or (null archive) + (tramp-archive-run-real-handler + #'file-directory-p (list archive))) + (tramp-archive-run-real-handler operation args) + ;; Now run the handler. + (let ((tramp-methods (cons `(,tramp-archive-method) tramp-methods)) + (tramp-gvfs-methods tramp-archive-all-gvfs-methods) + ;; Set uid and gid. gvfsd-archive could do it, but it doesn't. + (tramp-unknown-id-integer (user-uid)) + (tramp-unknown-id-string (user-login-name)) + (fn (assoc operation tramp-archive-file-name-handler-alist))) + (when (eq (cdr fn) #'tramp-archive-handle-not-implemented) + (setq args (cons operation args))) + (if fn + (save-match-data (apply (cdr fn) args)) + (tramp-archive-run-real-handler operation args))))))) + +;;;###autoload +(defalias + 'tramp-archive-autoload-file-name-handler #'tramp-autoload-file-name-handler) + +;;;###autoload +(progn (defun tramp-register-archive-file-name-handler () + "Add archive file name handler to `file-name-handler-alist'." + (when tramp-archive-enabled + (add-to-list 'file-name-handler-alist + (cons (tramp-archive-autoload-file-name-regexp) + #'tramp-archive-autoload-file-name-handler)) + (put 'tramp-archive-autoload-file-name-handler 'safe-magic t)))) + +;;;###autoload +(progn + (add-hook 'after-init-hook #'tramp-register-archive-file-name-handler) + (add-hook + 'tramp-archive-unload-hook + (lambda () + (remove-hook + 'after-init-hook #'tramp-register-archive-file-name-handler)))) + +;; In older Emacsen (prior 27.1), the autoload above does not exist. +;; So we call it again; it doesn't hurt. +(tramp-register-archive-file-name-handler) + +;; Mark `operations' the handler is responsible for. +(put 'tramp-archive-file-name-handler 'operations + (mapcar #'car tramp-archive-file-name-handler-alist)) + +;; `tramp-archive-file-name-handler' must be placed before `url-file-handler'. +(when url-handler-mode (tramp-register-file-name-handlers)) + +(with-eval-after-load 'url-handler + (add-hook 'url-handler-mode-hook #'tramp-register-file-name-handlers) + (add-hook + 'tramp-archive-unload-hook + (lambda () + (remove-hook + 'url-handler-mode-hook #'tramp-register-file-name-handlers)))) + + +;; File name conversions. + +(defun tramp-archive-file-name-p (name) + "Return t if NAME is a string with archive file name syntax." + (and (stringp name) + ;; `tramp-archive-file-name-regexp' does not suppress quoted file names. + (not (tramp-compat-file-name-quoted-p name t)) + ;; We cannot use `string-match-p', the matches are used. + (string-match tramp-archive-file-name-regexp name) + t)) + +(defun tramp-archive-file-name-archive (name) + "Return archive part of NAME." + (and (tramp-archive-file-name-p name) + (match-string 1 name))) + +(defun tramp-archive-file-name-localname (name) + "Return localname part of NAME." + (and (tramp-archive-file-name-p name) + (match-string 2 name))) + +(defvar tramp-archive-hash (make-hash-table :test 'equal) + "Hash table for archive local copies. +The hash key is the archive name. The value is a cons of the +used `tramp-file-name' structure for tramp-gvfs, and the file +name of a local copy, if any.") + +(defsubst tramp-archive-gvfs-host (archive) + "Return host name of ARCHIVE as used in GVFS for mounting" + (url-hexify-string (tramp-gvfs-url-file-name archive))) + +(defun tramp-archive-dissect-file-name (name) + "Return a `tramp-file-name' structure. +The structure consists of the `tramp-archive-method' method, the +hexified archive name as host, and the localname. The archive +name is kept in slot `hop'" + (save-match-data + (unless (tramp-archive-file-name-p name) + (tramp-user-error nil "Not an archive file name: \"%s\"" name)) + (let* ((localname (tramp-archive-file-name-localname name)) + (archive (file-truename (tramp-archive-file-name-archive name))) + (vec (make-tramp-file-name + :method tramp-archive-method :hop archive))) + + (cond + ;; The value is already in the hash table. + ((gethash archive tramp-archive-hash) + (setq vec (car (gethash archive tramp-archive-hash)))) + + ;; File archives inside file archives. + ((tramp-archive-file-name-p archive) + (let ((archive + (tramp-make-tramp-file-name + (tramp-archive-dissect-file-name archive) nil 'noarchive))) + (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive))) + (puthash archive (list vec) tramp-archive-hash)) + + ;; http://... + ((and url-handler-mode + tramp-compat-use-url-tramp-p + (string-match-p url-handler-regexp archive) + (string-match-p + "https?" (url-type (url-generic-parse-url archive)))) + (let* ((url-tramp-protocols + (cons + (url-type (url-generic-parse-url archive)) + url-tramp-protocols)) + (archive (url-tramp-convert-url-to-tramp archive))) + (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive))) + (puthash archive (list vec) tramp-archive-hash)) + + ;; GVFS supported schemes. + ((or (tramp-gvfs-file-name-p archive) + (not (file-remote-p archive))) + (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive)) + (puthash archive (list vec) tramp-archive-hash)) + + ;; Anything else. Here we call `file-local-copy', which we + ;; have avoided so far. + (t (let* ((inhibit-file-name-operation #'file-local-copy) + (inhibit-file-name-handlers + (cons #'jka-compr-handler inhibit-file-name-handlers)) + (copy (file-local-copy archive))) + (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host copy)) + (puthash archive (cons vec copy) tramp-archive-hash)))) + + ;; So far, `vec' handles just the mount point. Add `localname', + ;; which shouldn't be pushed to the hash. + (setf (tramp-file-name-localname vec) localname) + vec))) + +(defun tramp-archive-cleanup-hash () + "Remove local copies of archives, used by GVFS." + ;; Don't check for a proper method. + (let ((non-essential t)) + (maphash + (lambda (key value) + ;; Unmount local copy. + (ignore-errors + (tramp-message (car value) 3 "Unmounting %s" (or (cdr value) key)) + (tramp-gvfs-unmount (car value))) + ;; Delete local copy. + (ignore-errors (delete-file (cdr value))) + (remhash key tramp-archive-hash)) + tramp-archive-hash) + (clrhash tramp-archive-hash))) + +(add-hook 'tramp-cleanup-all-connections-hook #'tramp-archive-cleanup-hash) +(add-hook 'kill-emacs-hook #'tramp-archive-cleanup-hash) +(add-hook 'tramp-archive-unload-hook + (lambda () + (remove-hook 'tramp-cleanup-all-connections-hook + #'tramp-archive-cleanup-hash) + (remove-hook 'kill-emacs-hook + #'tramp-archive-cleanup-hash))) + +(defsubst tramp-file-name-archive (vec) + "Extract the archive file name from VEC. +VEC is expected to be a `tramp-file-name', with the method being +`tramp-archive-method', and the host being a coded URL. The +archive name is extracted from the hop part of the VEC structure." + (and (tramp-file-name-p vec) + (string-equal (tramp-file-name-method vec) tramp-archive-method) + (tramp-file-name-hop vec))) + +(defmacro with-parsed-tramp-archive-file-name (filename var &rest body) + "Parse an archive filename and make components available in the body. +This works exactly as `with-parsed-tramp-file-name' for the Tramp +file name structure returned by `tramp-archive-dissect-file-name'. +A variable `foo-archive' (or `archive') will be bound to the +archive name part of FILENAME, assuming `foo' (or nil) is the +value of VAR. OTOH, the variable `foo-hop' (or `hop') won't be +offered." + (declare (debug (form symbolp body)) + (indent 2)) + (let ((bindings + (mapcar (lambda (elem) + `(,(if var (intern (format "%s-%s" var elem)) elem) + (,(intern (format "tramp-file-name-%s" elem)) + ,(or var 'v)))) + `,(cons + 'archive + (delete 'hop (tramp-compat-tramp-file-name-slots)))))) + `(let* ((,(or var 'v) (tramp-archive-dissect-file-name ,filename)) + ,@bindings) + ;; We don't know which of those vars will be used, so we bind them all, + ;; and then add here a dummy use of all those variables, so we don't get + ;; flooded by warnings about those vars `body' didn't use. + (ignore ,@(mapcar #'car bindings)) + ,@body))) + +(defun tramp-archive-gvfs-file-name (name) + "Return FILENAME in GVFS syntax." + (tramp-make-tramp-file-name + (tramp-archive-dissect-file-name name) nil 'nohop)) + + +;; File name primitives. + +(defun tramp-archive-handle-access-file (filename string) + "Like `access-file' for Tramp files." + (access-file (tramp-archive-gvfs-file-name filename) string)) + +(defun tramp-archive-handle-copy-file + (filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Like `copy-file' for file archives." + (when (tramp-archive-file-name-p newname) + (tramp-error + (tramp-archive-dissect-file-name newname) 'file-error + "Permission denied: %s" newname)) + (copy-file + (tramp-archive-gvfs-file-name filename) newname ok-if-already-exists + keep-date preserve-uid-gid preserve-extended-attributes)) + +(defun tramp-archive-handle-directory-file-name (directory) + "Like `directory-file-name' for file archives." + (with-parsed-tramp-archive-file-name directory nil + (if (and (not (zerop (length localname))) + (eq (aref localname (1- (length localname))) ?/) + (not (string= localname "/"))) + (substring directory 0 -1) + ;; We do not want to leave the file archive. This would require + ;; unnecessary download of http-based file archives, for + ;; example. So we return `directory'. + directory))) + +(defun tramp-archive-handle-dired-uncache (dir) + "Like `dired-uncache' for file archives." + (dired-uncache (tramp-archive-gvfs-file-name dir))) + +(defun tramp-archive-handle-file-attributes (filename &optional id-format) + "Like `file-attributes' for file archives." + (file-attributes (tramp-archive-gvfs-file-name filename) id-format)) + +(defun tramp-archive-handle-file-executable-p (filename) + "Like `file-executable-p' for file archives." + (file-executable-p (tramp-archive-gvfs-file-name filename))) + +(defun tramp-archive-handle-file-local-copy (filename) + "Like `file-local-copy' for file archives." + (file-local-copy (tramp-archive-gvfs-file-name filename))) + +(defun tramp-archive-handle-file-name-all-completions (filename directory) + "Like `file-name-all-completions' for file archives." + (file-name-all-completions filename (tramp-archive-gvfs-file-name directory))) + +(defun tramp-archive-handle-file-readable-p (filename) + "Like `file-readable-p' for file archives." + (file-readable-p (tramp-archive-gvfs-file-name filename))) + +(defun tramp-archive-handle-file-system-info (filename) + "Like `file-system-info' for file archives." + (with-parsed-tramp-archive-file-name filename nil + (list (tramp-compat-file-attribute-size (file-attributes archive)) 0 0))) + +(defun tramp-archive-handle-file-truename (filename) + "Like `file-truename' for file archives." + (with-parsed-tramp-archive-file-name filename nil + (let ((local (or (file-symlink-p filename) localname))) + (unless (file-name-absolute-p local) + (setq local (expand-file-name local (file-name-directory localname)))) + (concat (file-truename archive) local)))) + +(defun tramp-archive-handle-insert-directory + (filename switches &optional wildcard full-directory-p) + "Like `insert-directory' for file archives." + (insert-directory + (tramp-archive-gvfs-file-name filename) switches wildcard full-directory-p) + (goto-char (point-min)) + (while (search-forward (tramp-archive-gvfs-file-name filename) nil 'noerror) + (replace-match filename))) + +(defun tramp-archive-handle-insert-file-contents + (filename &optional visit beg end replace) + "Like `insert-file-contents' for file archives." + (let ((result + (insert-file-contents + (tramp-archive-gvfs-file-name filename) visit beg end replace))) + (prog1 + (list (expand-file-name filename) + (cadr result)) + (when visit (setq buffer-file-name filename))))) + +(defun tramp-archive-handle-load + (file &optional noerror nomessage nosuffix must-suffix) + "Like `load' for file archives." + (load + (tramp-archive-gvfs-file-name file) noerror nomessage nosuffix must-suffix)) + +(defun tramp-archive-handle-temporary-file-directory () + "Like `temporary-file-directory' for file archives." + ;; If the default directory, the file archive, is located on a + ;; mounted directory, it is returned as it. Not what we want. + (with-parsed-tramp-archive-file-name default-directory nil + (let ((default-directory (file-name-directory archive))) + (tramp-compat-temporary-file-directory)))) + +(defun tramp-archive-handle-not-implemented (operation &rest args) + "Generic handler for operations not implemented for file archives." + (let ((v (ignore-errors + (tramp-archive-dissect-file-name + (apply #'tramp-archive-file-name-for-operation operation args))))) + (tramp-message v 10 "%s" (cons operation args)) + (tramp-error + v 'file-error + "Operation `%s' not implemented for file archives" operation))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-archive 'force))) + +(provide 'tramp-archive) + +;;; TODO: + +;; * Check, whether we could retrieve better file attributes like uid, +;; gid, permissions. See gvfsbackendarchive.c +;; (archive_file_set_info_from_entry), where it is commented out. +;; +;; * Implement write access, when possible. +;; https://bugzilla.gnome.org/show_bug.cgi?id=589617 + +;;; tramp-archive.el ends here diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 701d2c22102..40f74957f50 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -28,7 +28,7 @@ ;; An implementation of information caching for remote files. ;; Each connection, identified by a `tramp-file-name' structure or by -;; a process, has a unique cache. We distinguish 3 kind of caches, +;; a process, has a unique cache. We distinguish 4 kind of caches, ;; depending on the key: ;; ;; - localname is NIL. This are reusable properties. Examples: @@ -49,6 +49,17 @@ ;; 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. +;; +;; - The key is nil. This are temporary properties related to the +;; local machine. Examples: "parse-passwd" and "parse-group" keep +;; the results of parsing "/etc/passwd" and "/etc/group", +;; "{uid,gid}-{integer,string}" are the local uid and gid, and +;; "locale" is the used shell locale. + +;; Some properties are handled special: +;; +;; - "process-name", "process-buffer" and "first-password-request" are +;; not saved in the file `tramp-persistency-file-name'. ;;; Code: @@ -58,7 +69,7 @@ ;;; -- Cache -- ;;;###tramp-autoload -(defvar tramp-cache-data (make-hash-table :test 'equal) +(defvar tramp-cache-data (make-hash-table :test #'equal) "Hash table for remote files properties.") ;;;###tramp-autoload @@ -91,15 +102,12 @@ If it doesn't exist yet, it is created and initialized with matching entries of `tramp-connection-properties'." (or (gethash key tramp-cache-data) (let ((hash - (puthash key (make-hash-table :test 'equal) tramp-cache-data))) + (puthash key (make-hash-table :test #'equal) tramp-cache-data))) (when (tramp-file-name-p key) (dolist (elt tramp-connection-properties) - (when (string-match + (when (string-match-p (or (nth 0 elt) "") - (tramp-make-tramp-file-name - (tramp-file-name-method key) (tramp-file-name-user key) - (tramp-file-name-domain key) (tramp-file-name-host key) - (tramp-file-name-port key) nil)) + (tramp-make-tramp-file-name key 'noloc 'nohop)) (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) hash))) @@ -111,20 +119,24 @@ Returns DEFAULT if not set." (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) (setf (tramp-file-name-localname key) - (tramp-run-real-handler 'directory-file-name (list file)) + (tramp-run-real-handler #'directory-file-name (list file)) (tramp-file-name-hop key) nil) (let* ((hash (tramp-get-hash-table key)) (value (when (hash-table-p hash) (gethash property hash)))) - (if - ;; We take the value only if there is any, and + (if ;; We take the value only if there is any, and ;; `remote-file-name-inhibit-cache' indicates that it is still ;; valid. Otherwise, DEFAULT is set. (and (consp value) (or (null remote-file-name-inhibit-cache) (and (integerp remote-file-name-inhibit-cache) - (<= - (tramp-time-diff (current-time) (car value)) - remote-file-name-inhibit-cache)) + (time-less-p + ;; `current-time' can be nil once we get rid of Emacs 24. + (current-time) + (time-add + (car value) + ;; `seconds-to-time' can be removed once we get + ;; rid of Emacs 24. + (seconds-to-time remote-file-name-inhibit-cache)))) (and (consp remote-file-name-inhibit-cache) (time-less-p remote-file-name-inhibit-cache (car value))))) @@ -150,7 +162,7 @@ Returns VALUE." (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) (setf (tramp-file-name-localname key) - (tramp-run-real-handler 'directory-file-name (list file)) + (tramp-run-real-handler #'directory-file-name (list file)) (tramp-file-name-hop key) nil) (let ((hash (tramp-get-hash-table key))) ;; We put the timestamp there. @@ -167,10 +179,25 @@ Returns VALUE." value)) ;;;###tramp-autoload -(defun tramp-flush-file-property (key file) +(defun tramp-flush-file-property (key file property) + "Remove PROPERTY of FILE in the cache context of KEY." + ;; Unify localname. Remove hop from `tramp-file-name' structure. + (setq file (tramp-compat-file-name-unquote file) + key (copy-tramp-file-name key)) + (setf (tramp-file-name-localname key) + (tramp-run-real-handler #'directory-file-name (list file)) + (tramp-file-name-hop key) nil) + (remhash property (tramp-get-hash-table key)) + (tramp-message key 8 "%s %s" file property) + (when (>= tramp-verbose 10) + (let ((var (intern (concat "tramp-cache-set-count-" property)))) + (makunbound var)))) + +;;;###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))) + #'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) @@ -182,29 +209,29 @@ Returns VALUE." ;; Remove file properties of symlinks. (when (and (stringp truename) (not (string-equal file (directory-file-name truename)))) - (tramp-flush-file-property key truename)))) + (tramp-flush-file-properties key truename)))) ;;;###tramp-autoload -(defun tramp-flush-directory-property (key directory) +(defun tramp-flush-directory-properties (key directory) "Remove all properties of DIRECTORY in the cache context of KEY. Remove also properties of all files in subdirectories." (setq directory (tramp-compat-file-name-unquote directory)) (let* ((directory (tramp-run-real-handler - 'directory-file-name (list directory))) + #'directory-file-name (list directory))) (truename (tramp-get-file-property key directory "file-truename" nil))) (tramp-message key 8 "%s" directory) (maphash (lambda (key _value) (when (and (tramp-file-name-p key) (stringp (tramp-file-name-localname key)) - (string-match (regexp-quote directory) - (tramp-file-name-localname key))) + (string-match-p (regexp-quote directory) + (tramp-file-name-localname key))) (remhash key tramp-cache-data))) tramp-cache-data) ;; Remove file properties of symlinks. (when (and (stringp truename) (not (string-equal directory (directory-file-name truename)))) - (tramp-flush-directory-property key truename)))) + (tramp-flush-directory-properties key truename)))) ;; Reverting or killing a buffer should also flush file properties. ;; They could have been changed outside Tramp. In eshell, "ls" would @@ -216,26 +243,26 @@ Remove also properties of all files in subdirectories." This is suppressed for temporary buffers." (save-match-data (unless (or (null (buffer-name)) - (string-match "^\\( \\|\\*\\)" (buffer-name))) + (string-match-p "^\\( \\|\\*\\)" (buffer-name))) (let ((bfn (if (stringp (buffer-file-name)) (buffer-file-name) default-directory)) (tramp-verbose 0)) (when (tramp-tramp-file-p bfn) (with-parsed-tramp-file-name bfn nil - (tramp-flush-file-property v localname))))))) + (tramp-flush-file-properties v localname))))))) -(add-hook 'before-revert-hook 'tramp-flush-file-function) -(add-hook 'eshell-pre-command-hook 'tramp-flush-file-function) -(add-hook 'kill-buffer-hook 'tramp-flush-file-function) +(add-hook 'before-revert-hook #'tramp-flush-file-function) +(add-hook 'eshell-pre-command-hook #'tramp-flush-file-function) +(add-hook 'kill-buffer-hook #'tramp-flush-file-function) (add-hook 'tramp-cache-unload-hook (lambda () (remove-hook 'before-revert-hook - 'tramp-flush-file-function) + #'tramp-flush-file-function) (remove-hook 'eshell-pre-command-hook - 'tramp-flush-file-function) + #'tramp-flush-file-function) (remove-hook 'kill-buffer-hook - 'tramp-flush-file-function))) + #'tramp-flush-file-function))) ;;; -- Properties -- @@ -292,7 +319,24 @@ used to cache connection properties of the local machine." (not (eq (tramp-get-connection-property key property 'undef) 'undef))) ;;;###tramp-autoload -(defun tramp-flush-connection-property (key) +(defun tramp-flush-connection-property (key property) + "Remove the named PROPERTY of a connection identified by KEY. +KEY identifies the connection, it is either a process or a +`tramp-file-name' structure. A special case is nil, which is +used to cache connection properties of the local machine. +PROPERTY is set persistent when KEY is a `tramp-file-name' structure." + ;; Unify key by removing localname and hop from `tramp-file-name' + ;; structure. Work with a copy in order to avoid side effects. + (when (tramp-file-name-p key) + (setq key (copy-tramp-file-name key)) + (setf (tramp-file-name-localname key) nil + (tramp-file-name-hop key) nil)) + (remhash property (tramp-get-hash-table key)) + (setq tramp-cache-data-changed t) + (tramp-message key 7 "%s" property)) + +;;;###tramp-autoload +(defun tramp-flush-connection-properties (key) "Remove all properties identified by KEY. KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is @@ -326,7 +370,7 @@ used to cache connection properties of the local machine." (when (tramp-file-name-p key) ;; (dolist ;; (slot - ;; (mapcar 'car (cdr (cl-struct-slot-info 'tramp-file-name)))) + ;; (mapcar #'car (cdr (cl-struct-slot-info 'tramp-file-name)))) ;; (when (stringp (cl-struct-slot-value 'tramp-file-name slot key)) ;; (setf (cl-struct-slot-value 'tramp-file-name slot key) ;; (substring-no-properties @@ -385,6 +429,8 @@ used to cache connection properties of the local machine." (maphash (lambda (key value) (if (and (tramp-file-name-p key) value + (not (string-equal + (tramp-file-name-method key) tramp-archive-method)) (not (tramp-file-name-localname key)) (not (gethash "login-as" value)) (not (gethash "started" value))) @@ -412,11 +458,11 @@ used to cache connection properties of the local machine." (pp (read (format "(%s)" (tramp-cache-print cache))))))))))) (unless noninteractive - (add-hook 'kill-emacs-hook 'tramp-dump-connection-properties)) + (add-hook 'kill-emacs-hook #'tramp-dump-connection-properties)) (add-hook 'tramp-cache-unload-hook (lambda () (remove-hook 'kill-emacs-hook - 'tramp-dump-connection-properties))) + #'tramp-dump-connection-properties))) ;;;###tramp-autoload (defun tramp-parse-connection-properties (method) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 1d35aa5a019..35bb85b82d9 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -55,9 +55,9 @@ SYNTAX can be one of the symbols `default' (default), "Return a list of all Tramp connection buffers." (append (all-completions - "*tramp" (mapcar 'list (mapcar 'buffer-name (buffer-list)))) + "*tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list)))) (all-completions - "*debug tramp" (mapcar 'list (mapcar 'buffer-name (buffer-list)))))) + "*debug tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list)))))) (defun tramp-list-remote-buffers () "Return a list of all buffers with remote default-directory." @@ -69,6 +69,11 @@ SYNTAX can be one of the symbols `default' (default), (buffer-list)))) ;;;###tramp-autoload +(defvar tramp-cleanup-connection-hook nil + "List of functions to be called after Tramp connection is cleaned up. +Each function is called with the current vector as argument.") + +;;;###tramp-autoload (defun tramp-cleanup-connection (vec &optional keep-debug keep-password) "Flush all connection related objects. This includes password cache, file cache, connection cache, @@ -80,16 +85,7 @@ When called interactively, a Tramp connection has to be selected." ;; Return nil when there is no Tramp connection. (list (let ((connections - (mapcar - (lambda (x) - (tramp-make-tramp-file-name - (tramp-file-name-method x) - (tramp-file-name-user x) - (tramp-file-name-domain x) - (tramp-file-name-host x) - (tramp-file-name-port x) - (tramp-file-name-localname x))) - (tramp-list-connections))) + (mapcar #'tramp-make-tramp-file-name (tramp-list-connections))) name) (when connections @@ -108,18 +104,23 @@ When called interactively, a Tramp connection has to be selected." (unless keep-password (tramp-clear-passwd vec)) ;; Cleanup `tramp-current-connection'. Otherwise, we would be - ;; suppressed in the test suite. We use `keep-password' as - ;; indicator; it is not worth to add a new argument. - (when keep-password (setq tramp-current-connection nil)) + ;; suppressed. + (setq tramp-current-connection nil) ;; Flush file cache. - (tramp-flush-directory-property vec "") + (tramp-flush-directory-properties vec "") ;; Flush connection cache. (when (processp (tramp-get-connection-process vec)) - (tramp-flush-connection-property (tramp-get-connection-process vec)) + (tramp-flush-connection-properties (tramp-get-connection-process vec)) (delete-process (tramp-get-connection-process vec))) - (tramp-flush-connection-property vec) + (tramp-flush-connection-properties vec) + + ;; Cancel timer. + (dolist (timer timer-list) + (when (and (eq (timer--function timer) 'tramp-timeout-session) + (tramp-file-name-equal-p vec (car (timer--args timer)))) + (cancel-timer timer))) ;; Remove buffers. (dolist @@ -127,7 +128,10 @@ When called interactively, a Tramp connection has to be selected." (unless keep-debug (get-buffer (tramp-debug-buffer-name vec))) (tramp-get-connection-property vec "process-buffer" nil))) - (when (bufferp buf) (kill-buffer buf))))) + (when (bufferp buf) (kill-buffer buf))) + + ;; The end. + (run-hook-with-args 'tramp-cleanup-connection-hook vec))) ;;;###tramp-autoload (defun tramp-cleanup-this-connection () @@ -138,6 +142,10 @@ When called interactively, a Tramp connection has to be selected." (tramp-dissect-file-name default-directory 'noexpand)))) ;;;###tramp-autoload +(defvar tramp-cleanup-all-connections-hook nil + "List of functions to be called after all Tramp connections are cleaned up.") + +;;;###tramp-autoload (defun tramp-cleanup-all-connections () "Flush all Tramp internal objects. This includes password cache, file cache, connection cache, buffers." @@ -152,9 +160,28 @@ This includes password cache, file cache, connection cache, buffers." ;; Flush file and connection cache. (clrhash tramp-cache-data) + ;; Remove ad-hoc proxies. + (let ((proxies tramp-default-proxies-alist)) + (while proxies + (if (ignore-errors + (get-text-property 0 'tramp-ad-hoc (nth 2 (car proxies)))) + (setq tramp-default-proxies-alist + (delete (car proxies) tramp-default-proxies-alist) + proxies tramp-default-proxies-alist) + (setq proxies (cdr proxies))))) + (when (and tramp-default-proxies-alist tramp-save-ad-hoc-proxies) + (customize-save-variable + 'tramp-default-proxies-alist tramp-default-proxies-alist)) + + ;; Cancel timers. + (cancel-function-timers 'tramp-timeout-session) + ;; Remove buffers. (dolist (name (tramp-list-tramp-buffers)) - (when (bufferp (get-buffer name)) (kill-buffer name)))) + (when (bufferp (get-buffer name)) (kill-buffer name))) + + ;; The end. + (run-hooks 'tramp-cleanup-all-connections-hook)) ;;;###tramp-autoload (defun tramp-cleanup-all-buffers () @@ -185,36 +212,38 @@ This includes password cache, file cache, connection cache, buffers." (defun tramp-bug () "Submit a bug report to the Tramp developers." (interactive) - (catch 'dont-send - (let ((reporter-prompt-for-summary-p t)) - (reporter-submit-bug-report - tramp-bug-report-address ; to-address - (format "tramp (%s)" tramp-version) ; package name and version - (sort - (delq nil (mapcar - (lambda (x) - (and x (boundp x) (cons x 'tramp-reporter-dump-variable))) - (append - (mapcar 'intern (all-completions "tramp-" obarray 'boundp)) - ;; Non-tramp variables of interest. - '(shell-prompt-pattern - backup-by-copying - backup-by-copying-when-linked - backup-by-copying-when-mismatch - backup-by-copying-when-privileged-mismatch - backup-directory-alist - password-cache - password-cache-expiry - remote-file-name-inhibit-cache - connection-local-profile-alist - connection-local-criteria-alist - file-name-handler-alist)))) - (lambda (x y) (string< (symbol-name (car x)) (symbol-name (car y))))) - - 'tramp-load-report-modules ; pre-hook - 'tramp-append-tramp-buffers ; post-hook - (propertize - "\n" 'display "\ + (let ((reporter-prompt-for-summary-p t) + ;; In rare cases, it could contain the password. So we make it nil. + tramp-password-save-function) + (reporter-submit-bug-report + tramp-bug-report-address ; to-address + (format "tramp (%s %s/%s)" ; package name and version + tramp-version tramp-repository-branch tramp-repository-version) + (sort + (delq nil (mapcar + (lambda (x) + (and x (boundp x) (cons x 'tramp-reporter-dump-variable))) + (append + (mapcar #'intern (all-completions "tramp-" obarray #'boundp)) + ;; Non-tramp variables of interest. + '(shell-prompt-pattern + backup-by-copying + backup-by-copying-when-linked + backup-by-copying-when-mismatch + backup-by-copying-when-privileged-mismatch + backup-directory-alist + password-cache + password-cache-expiry + remote-file-name-inhibit-cache + connection-local-profile-alist + connection-local-criteria-alist + file-name-handler-alist)))) + (lambda (x y) (string< (symbol-name (car x)) (symbol-name (car y))))) + + 'tramp-load-report-modules ; pre-hook + 'tramp-append-tramp-buffers ; post-hook + (propertize + "\n" 'display "\ Enter your bug report in this message, including as much detail as you possibly can about the problem, what you did to cause it and what the local and remote machines are. @@ -237,7 +266,7 @@ contents of the *tramp/foo* buffer and the *debug tramp/foo* buffer in your bug report. --bug report follows this line-- -"))))) +")))) (defun tramp-reporter-dump-variable (varsym mailbuf) "Pretty-print the value of the variable in symbol VARSYM." @@ -250,7 +279,7 @@ buffer in your bug report. (set varsym (read (format "(%s)" (tramp-cache-print val)))) ;; There are non-7bit characters to be masked. (when (and (stringp val) - (string-match + (string-match-p (concat "[^" (bound-and-true-p mm-7bit-chars) "]") val)) (with-current-buffer reporter-eval-buffer (set @@ -266,10 +295,11 @@ buffer in your bug report. ;; Remove string quotation. (forward-line -1) (when (looking-at - (concat "\\(^.*\\)" "\"" ;; \1 " - "\\((base64-decode-string \\)" "\\\\" ;; \2 \ - "\\(\".*\\)" "\\\\" ;; \3 \ - "\\(\")\\)" "\"$")) ;; \4 " + (eval-when-compile + (concat "\\(^.*\\)" "\"" ;; \1 " + "\\((base64-decode-string \\)" "\\\\" ;; \2 \ + "\\(\".*\\)" "\\\\" ;; \3 \ + "\\(\")\\)" "\"$"))) ;; \4 " (replace-match "\\1\\2\\3\\4") (beginning-of-line) (insert " ;; Variable encoded due to non-printable characters.\n")) @@ -294,7 +324,7 @@ buffer in your bug report. (delq nil (mapcar (lambda (b) - (when (string-match "\\*tramp/" (buffer-name b)) b)) + (when (string-match-p "\\*tramp/" (buffer-name b)) b)) (buffer-list)))) (let ((reporter-eval-buffer buffer) (elbuf (get-buffer-create " *tmp-reporter-buffer*"))) @@ -308,11 +338,11 @@ buffer in your bug report. (sort (append (mapcar - 'intern + #'intern (all-completions "tramp-" (buffer-local-variables buffer))) ;; Non-tramp variables of interest. '(connection-local-variables-alist default-directory)) - 'string<)) + #'string<)) (reporter-dump-variable varsym elbuf)) (lisp-indent-line) (insert ")\n")) @@ -322,7 +352,7 @@ buffer in your bug report. (insert "\nload-path shadows:\n==================\n") (ignore-errors (mapc - (lambda (x) (when (string-match "tramp" x) (insert x "\n"))) + (lambda (x) (when (string-match-p "tramp" x) (insert x "\n"))) (split-string (list-load-path-shadows t) "\n"))) ;; Append buffers only when we are in message mode. @@ -367,30 +397,23 @@ the debug buffer(s).") (setq buffer-read-only t) (goto-char (point-min)) - (if (y-or-n-p "Do you want to append the buffer(s)? ") - ;; OK, let's send. First we delete the buffer list. - (progn - (kill-buffer nil) - (switch-to-buffer curbuf) - (goto-char (point-max)) - (insert (propertize "\n" 'display "\n\ + (when (y-or-n-p "Do you want to append the buffer(s)? ") + ;; OK, let's send. First we delete the buffer list. + (kill-buffer nil) + (switch-to-buffer curbuf) + (goto-char (point-max)) + (insert (propertize "\n" 'display "\n\ This is a special notion of the `gnus/message' package. If you use another mail agent (by copying the contents of this buffer) please ensure that the buffers are attached to your email.\n\n")) - (dolist (buffer buffer-list) - (mml-insert-empty-tag - 'part 'type "text/plain" - 'encoding "base64" 'disposition "attachment" 'buffer buffer - 'description buffer)) - (set-buffer-modified-p nil)) - - ;; Don't send. Delete the message buffer. - (set-buffer curbuf) - (set-buffer-modified-p nil) - (kill-buffer nil) - (throw 'dont-send nil)))))) - -(defalias 'tramp-submit-bug 'tramp-bug) + (dolist (buffer buffer-list) + (mml-insert-empty-tag + 'part 'type "text/plain" + 'encoding "base64" 'disposition "attachment" 'buffer buffer + 'description buffer)) + (set-buffer-modified-p nil)))))) + +(defalias 'tramp-submit-bug #'tramp-bug) (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-cmds 'force))) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index ccb1d1ce327..4f01f8d372f 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -29,19 +29,19 @@ ;;; Code: +;; In Emacs 24 and 25, `tramp-unload-file-name-handlers' is not +;; autoloaded. So we declare it here in order to avoid recursive +;; load. This will be overwritten in tramp.el. +(defun tramp-unload-file-name-handlers ()) + (require 'auth-source) -(require 'advice) -(require 'cl-lib) -(require 'custom) (require 'format-spec) +(require 'ls-lisp) ;; Due to `tramp-handle-insert-directory'. (require 'parse-time) -(require 'password-cache) (require 'shell) -(require 'timer) -(require 'ucs-normalize) +(require 'subr-x) -(require 'trampver) -(require 'tramp-loaddefs) +(declare-function tramp-handle-temporary-file-directory "tramp") ;; For not existing functions, obsolete functions, or functions with a ;; changed argument list, there are compiler warnings. We want to @@ -71,8 +71,8 @@ Add the extension of F, if existing." ;; `temporary-file-directory' as function is introduced with Emacs 26.1. (defalias 'tramp-compat-temporary-file-directory-function (if (fboundp 'temporary-file-directory) - 'temporary-file-directory - 'tramp-handle-temporary-file-directory)) + #'temporary-file-directory + #'tramp-handle-temporary-file-directory)) (defun tramp-compat-process-running-p (process-name) "Returns t if system process PROCESS-NAME is running for `user-login-name'." @@ -82,7 +82,7 @@ Add the extension of F, if existing." ((fboundp 'w32-window-exists-p) (tramp-compat-funcall 'w32-window-exists-p process-name process-name)) - ;; GNU Emacs 23. + ;; GNU Emacs 23+. ((and (fboundp 'list-system-processes) (fboundp 'process-attributes)) (let (result) (dolist (pid (tramp-compat-funcall 'list-system-processes) result) @@ -93,146 +93,149 @@ Add the extension of F, if existing." ;; The returned command name could be truncated ;; to 15 characters. Therefore, we cannot check ;; for `string-equal'. - (and comm (string-match + (and comm (string-match-p (concat "^" (regexp-quote comm)) process-name)))) (setq result t))))))))) -;; `user-error' has appeared in Emacs 24.3. -(defsubst tramp-compat-user-error (vec-or-proc format &rest args) - "Signal a pilot error." - (apply - 'tramp-error vec-or-proc - (if (fboundp 'user-error) 'user-error 'error) format args)) - -;; `default-toplevel-value' has been declared in Emacs 24.4. -(unless (fboundp 'default-toplevel-value) - (defalias 'default-toplevel-value 'symbol-value)) - ;; `file-attribute-*' are introduced in Emacs 25.1. -(if (fboundp 'file-attribute-type) - (defalias 'tramp-compat-file-attribute-type 'file-attribute-type) - (defsubst tramp-compat-file-attribute-type (attributes) - "The type field in ATTRIBUTES returned by `file-attributes'. +(defalias 'tramp-compat-file-attribute-type + (if (fboundp 'file-attribute-type) + #'file-attribute-type + (lambda (attributes) + "The type field in ATTRIBUTES returned by `file-attributes'. The value is either t for directory, string (name linked to) for symbolic link, or nil." - (nth 0 attributes))) - -(if (fboundp 'file-attribute-link-number) - (defalias 'tramp-compat-file-attribute-link-number - 'file-attribute-link-number) - (defsubst tramp-compat-file-attribute-link-number (attributes) - "Return the number of links in ATTRIBUTES returned by `file-attributes'." - (nth 1 attributes))) - -(if (fboundp 'file-attribute-user-id) - (defalias 'tramp-compat-file-attribute-user-id 'file-attribute-user-id) - (defsubst tramp-compat-file-attribute-user-id (attributes) - "The UID field in ATTRIBUTES returned by `file-attributes'. + (nth 0 attributes)))) + +(defalias 'tramp-compat-file-attribute-link-number + (if (fboundp 'file-attribute-link-number) + #'file-attribute-link-number + (lambda (attributes) + "Return the number of links in ATTRIBUTES returned by `file-attributes'." + (nth 1 attributes)))) + +(defalias 'tramp-compat-file-attribute-user-id + (if (fboundp 'file-attribute-user-id) + #'file-attribute-user-id + (lambda (attributes) + "The UID field in ATTRIBUTES returned by `file-attributes'. This is either a string or a number. If a string value cannot be looked up, a numeric value, either an integer or a float, is returned." - (nth 2 attributes))) + (nth 2 attributes)))) -(if (fboundp 'file-attribute-group-id) - (defalias 'tramp-compat-file-attribute-group-id 'file-attribute-group-id) - (defsubst tramp-compat-file-attribute-group-id (attributes) - "The GID field in ATTRIBUTES returned by `file-attributes'. +(defalias 'tramp-compat-file-attribute-group-id + (if (fboundp 'file-attribute-group-id) + #'file-attribute-group-id + (lambda (attributes) + "The GID field in ATTRIBUTES returned by `file-attributes'. This is either a string or a number. If a string value cannot be looked up, a numeric value, either an integer or a float, is returned." - (nth 3 attributes))) + (nth 3 attributes)))) -(if (fboundp 'file-attribute-modification-time) - (defalias 'tramp-compat-file-attribute-modification-time - 'file-attribute-modification-time) - (defsubst tramp-compat-file-attribute-modification-time (attributes) - "The modification time in ATTRIBUTES returned by `file-attributes'. +(defalias 'tramp-compat-file-attribute-modification-time + (if (fboundp 'file-attribute-modification-time) + #'file-attribute-modification-time + (lambda (attributes) + "The modification time in ATTRIBUTES returned by `file-attributes'. This is the time of the last change to the file's contents, and -is a list of integers (HIGH LOW USEC PSEC) in the same style -as (current-time)." - (nth 5 attributes))) - -(if (fboundp 'file-attribute-size) - (defalias 'tramp-compat-file-attribute-size 'file-attribute-size) - (defsubst tramp-compat-file-attribute-size (attributes) - "The size (in bytes) in ATTRIBUTES returned by `file-attributes'. -This is a floating point number if the size is too large for an integer." - (nth 7 attributes))) - -(if (fboundp 'file-attribute-modes) - (defalias 'tramp-compat-file-attribute-modes 'file-attribute-modes) - (defsubst tramp-compat-file-attribute-modes (attributes) - "The file modes in ATTRIBUTES returned by `file-attributes'. +is a Lisp timestamp in the style of `current-time'." + (nth 5 attributes)))) + +(defalias 'tramp-compat-file-attribute-size + (if (fboundp 'file-attribute-size) + #'file-attribute-size + (lambda (attributes) + "The size (in bytes) in ATTRIBUTES returned by `file-attributes'. +If the size is too large for a fixnum, this is a bignum in Emacs 27 +and later, and is a float in Emacs 26 and earlier." + (nth 7 attributes)))) + +(defalias 'tramp-compat-file-attribute-modes + (if (fboundp 'file-attribute-modes) + #'file-attribute-modes + (lambda (attributes) + "The file modes in ATTRIBUTES returned by `file-attributes'. This is a string of ten letters or dashes as in ls -l." - (nth 8 attributes))) + (nth 8 attributes)))) ;; `format-message' is new in Emacs 25.1. (unless (fboundp 'format-message) - (defalias 'format-message 'format)) + (defalias 'format-message #'format)) ;; `directory-name-p' is new in Emacs 25.1. -(if (fboundp 'directory-name-p) - (defalias 'tramp-compat-directory-name-p 'directory-name-p) - (defsubst tramp-compat-directory-name-p (name) - "Return non-nil if NAME ends with a directory separator character." - (let ((len (length name)) - (lastc ?.)) - (if (> len 0) - (setq lastc (aref name (1- len)))) - (or (= lastc ?/) - (and (memq system-type '(windows-nt ms-dos)) - (= lastc ?\\)))))) +(defalias 'tramp-compat-directory-name-p + (if (fboundp 'directory-name-p) + #'directory-name-p + (lambda (name) + "Return non-nil if NAME ends with a directory separator character." + (let ((len (length name)) + (lastc ?.)) + (if (> len 0) + (setq lastc (aref name (1- len)))) + (or (= lastc ?/) + (and (memq system-type '(windows-nt ms-dos)) + (= lastc ?\\))))))) ;; `file-missing' is introduced in Emacs 26.1. (defconst tramp-file-missing (if (get 'file-missing 'error-conditions) 'file-missing 'file-error) "The error symbol for the `file-missing' error.") -(add-hook 'tramp-unload-hook - (lambda () - (unload-feature 'tramp-loaddefs 'force) - (unload-feature 'tramp-compat 'force))) - -;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' are -;; introduced in Emacs 26. -(eval-and-compile - (if (fboundp 'file-name-quoted-p) - (defalias 'tramp-compat-file-name-quoted-p 'file-name-quoted-p) - (defsubst tramp-compat-file-name-quoted-p (name) +;; `file-local-name', `file-name-quoted-p', `file-name-quote' and +;; `file-name-unquote' are introduced in Emacs 26. +(defalias 'tramp-compat-file-local-name + (if (fboundp 'file-local-name) + #'file-local-name + (lambda (name) + "Return the local name component of NAME. +It returns a file name which can be used directly as argument of +`process-file', `start-file-process', or `shell-command'." + (or (file-remote-p name 'localname) name)))) + +;; `file-name-quoted-p' got a second argument in Emacs 27.1. +(defalias 'tramp-compat-file-name-quoted-p + (if (and + (fboundp 'file-name-quoted-p) + (equal (tramp-compat-funcall 'func-arity #'file-name-quoted-p) '(1 . 2))) + #'file-name-quoted-p + (lambda (name &optional top) "Whether NAME is quoted with prefix \"/:\". -If NAME is a remote file name, check the local part of NAME." - (string-match "^/:" (or (file-remote-p name 'localname) name)))) +If NAME is a remote file name and TOP is nil, check the local part of NAME." + (let ((file-name-handler-alist (unless top file-name-handler-alist))) + (string-prefix-p "/:" (tramp-compat-file-local-name name)))))) +(defalias 'tramp-compat-file-name-quote (if (fboundp 'file-name-quote) - (defalias 'tramp-compat-file-name-quote 'file-name-quote) - (defsubst tramp-compat-file-name-quote (name) + #'file-name-quote + (lambda (name) "Add the quotation prefix \"/:\" to file NAME. If NAME is a remote file name, the local part of NAME is quoted." (if (tramp-compat-file-name-quoted-p name) name (concat - (file-remote-p name) "/:" (or (file-remote-p name 'localname) name))))) + (file-remote-p name) "/:" (tramp-compat-file-local-name name)))))) +(defalias 'tramp-compat-file-name-unquote (if (fboundp 'file-name-unquote) - (defalias 'tramp-compat-file-name-unquote 'file-name-unquote) - (defsubst tramp-compat-file-name-unquote (name) + #'file-name-unquote + (lambda (name) "Remove quotation prefix \"/:\" from file NAME. If NAME is a remote file name, the local part of NAME is unquoted." - (save-match-data - (let ((localname (or (file-remote-p name 'localname) name))) - (when (tramp-compat-file-name-quoted-p localname) - (setq - localname - (replace-match - (if (= (length localname) 2) "/" "") nil t localname))) - (concat (file-remote-p name) localname)))))) + (let ((localname (tramp-compat-file-local-name name))) + (when (tramp-compat-file-name-quoted-p localname) + (setq + localname (if (= (length localname) 2) "/" (substring localname 2)))) + (concat (file-remote-p name) localname))))) ;; `tramp-syntax' has changed its meaning in Emacs 26. We still ;; support old settings. (defsubst tramp-compat-tramp-syntax () "Return proper value of `tramp-syntax'." + (defvar tramp-syntax) (cond ((eq tramp-syntax 'ftp) 'default) ((eq tramp-syntax 'sep) 'separate) (t tramp-syntax))) @@ -240,11 +243,64 @@ If NAME is a remote file name, the local part of NAME is unquoted." ;; `cl-struct-slot-info' has been introduced with Emacs 25. (defmacro tramp-compat-tramp-file-name-slots () (if (fboundp 'cl-struct-slot-info) - `(cdr (mapcar 'car (cl-struct-slot-info 'tramp-file-name))) - `(cdr (mapcar 'car (get 'tramp-file-name 'cl-struct-slots))))) + '(cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name))) + '(cdr (mapcar #'car (get 'tramp-file-name 'cl-struct-slots))))) + +;; The signature of `tramp-make-tramp-file-name' has been changed. +;; Therefore, we cannot use `url-tramp-convert-url-to-tramp' prior +;; Emacs 26.1. We use `temporary-file-directory' as indicator. +(defconst tramp-compat-use-url-tramp-p (fboundp 'temporary-file-directory) + "Whether to use url-tramp.el.") + +;; `exec-path' is new in Emacs 27.1. +(defalias 'tramp-compat-exec-path + (if (fboundp 'exec-path) + #'exec-path + (lambda () + "List of directories to search programs to run in remote subprocesses." + (let ((handler (find-file-name-handler default-directory 'exec-path))) + (if handler + (funcall handler 'exec-path) + exec-path))))) + +;; `time-equal-p' has appeared in Emacs 27.1. +(defalias 'tramp-compat-time-equal-p + (if (fboundp 'time-equal-p) + #'time-equal-p + (lambda (t1 t2) + "Return non-nil if time value T1 is equal to time value T2. +A nil value for either argument stands for the current time." + (equal (or t1 (current-time)) (or t2 (current-time)))))) + +;; `flatten-tree' has appeared in Emacs 27.1. +(defalias 'tramp-compat-flatten-tree + (if (fboundp 'flatten-tree) + #'flatten-tree + (lambda (tree) + "Take TREE and \"flatten\" it." + (let (elems) + (setq tree (list tree)) + (while (let ((elem (pop tree))) + (cond ((consp elem) + (setq tree (cons (car elem) (cons (cdr elem) tree)))) + (elem + (push elem elems))) + tree)) + (nreverse elems))))) + +;; `progress-reporter-update' got argument SUFFIX in Emacs 27.1. +(defalias 'tramp-compat-progress-reporter-update + (if (equal (tramp-compat-funcall 'func-arity #'progress-reporter-update) + '(1 . 3)) + #'progress-reporter-update + (lambda (reporter &optional value _suffix) + (progress-reporter-update reporter value)))) -(provide 'tramp-compat) +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-loaddefs 'force) + (unload-feature 'tramp-compat 'force))) -;;; TODO: +(provide 'tramp-compat) ;;; tramp-compat.el ends here diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index de9bb4024da..2a4fccf57e7 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -53,11 +53,10 @@ present for backward compatibility." (setq file-name-handler-alist (delete a1 (delete a2 file-name-handler-alist))))) -(eval-after-load "ange-ftp" - '(when (functionp 'tramp-disable-ange-ftp) - (tramp-disable-ange-ftp))) +(with-eval-after-load 'ange-ftp + (tramp-disable-ange-ftp)) -;;;###autoload +;;;###tramp-autoload (defun tramp-ftp-enable-ange-ftp () "Reenable Ange-FTP, when Tramp is unloaded." ;; The following code is commented out in Ange-FTP. @@ -86,7 +85,7 @@ present for backward compatibility." ange-ftp-completion-hook-function) file-name-handler-alist))))) -(add-hook 'tramp-ftp-unload-hook 'tramp-ftp-enable-ange-ftp) +(add-hook 'tramp-ftp-unload-hook #'tramp-ftp-enable-ange-ftp) ;; Define FTP method ... ;;;###tramp-autoload @@ -95,22 +94,19 @@ present for backward compatibility." ;; ... and add it to the method list. ;;;###tramp-autoload -(add-to-list 'tramp-methods (cons tramp-ftp-method nil)) +(tramp--with-startup + (add-to-list 'tramp-methods (cons tramp-ftp-method nil)) -;; Add some defaults for `tramp-default-method-alist'. -;;;###tramp-autoload -(add-to-list 'tramp-default-method-alist - (list "\\`ftp\\." nil tramp-ftp-method)) -;;;###tramp-autoload -(add-to-list 'tramp-default-method-alist - (list nil "\\`\\(anonymous\\|ftp\\)\\'" tramp-ftp-method)) + ;; Add some defaults for `tramp-default-method-alist'. + (add-to-list 'tramp-default-method-alist + (list "\\`ftp\\." nil tramp-ftp-method)) + (add-to-list 'tramp-default-method-alist + (list nil "\\`\\(anonymous\\|ftp\\)\\'" tramp-ftp-method)) -;; Add completion function for FTP method. -;;;###tramp-autoload -(eval-after-load 'tramp - '(tramp-set-completion-function - tramp-ftp-method - '((tramp-parse-netrc "~/.netrc")))) + ;; Add completion function for FTP method. + (tramp-set-completion-function + tramp-ftp-method + '((tramp-parse-netrc "~/.netrc")))) ;;;###tramp-autoload (defun tramp-ftp-file-name-handler (operation &rest args) @@ -142,7 +138,7 @@ pass to the OPERATION." ;; because this returns another user but the one declared in ;; "~/.netrc". ((memq operation '(file-directory-p file-exists-p)) - (if (apply 'ange-ftp-hook-function operation args) + (if (apply #'ange-ftp-hook-function operation args) (let ((v (tramp-dissect-file-name (car args) t))) (setf (tramp-file-name-method v) tramp-ftp-method) (tramp-set-connection-property v "started" t)) @@ -176,19 +172,21 @@ pass to the OPERATION." (and (eq inhibit-file-name-operation operation) inhibit-file-name-handlers))) (inhibit-file-name-operation operation)) - (apply 'ange-ftp-hook-function operation args))))))) + (apply #'ange-ftp-hook-function operation args))))))) ;; 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-ftp-file-name-p (filename) "Check if it's a filename that should be forwarded to Ange-FTP." - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-ftp-method)) + (and (tramp-tramp-file-p filename) + (string= (tramp-file-name-method (tramp-dissect-file-name filename)) + tramp-ftp-method))) ;;;###tramp-autoload -(add-to-list 'tramp-foreign-file-name-handler-alist - (cons 'tramp-ftp-file-name-p 'tramp-ftp-file-name-handler)) +(tramp--with-startup + (add-to-list 'tramp-foreign-file-name-handler-alist + (cons #'tramp-ftp-file-name-p #'tramp-ftp-file-name-handler))) (add-hook 'tramp-unload-hook (lambda () diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 4a4be5c51f3..9d45e6a8ce9 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -47,17 +47,19 @@ ;; discovered during development time, is given in respective ;; comments. -;; The custom option `tramp-gvfs-methods' contains the list of -;; supported connection methods. Per default, these are "afp", "dav", -;; "davs", "gdrive", "obex", "sftp" and "synce". Note that with -;; "obex" it might be necessary to pair with the other bluetooth -;; device, if it hasn't been done already. There might be also some -;; few seconds delay in discovering available bluetooth devices. - -;; Other possible connection methods are "ftp" and "smb". When one of -;; these methods is added to the list, the remote access for that -;; method is performed via GVFS instead of the native Tramp -;; implementation. +;; The user option `tramp-gvfs-methods' contains the list of supported +;; connection methods. Per default, these are "afp", "dav", "davs", +;; "gdrive", "nextcloud" and "sftp". + +;; "gdrive" and "nextcloud" connection methods require a respective +;; account in GNOME Online Accounts, with enabled "Files" service. + +;; Other possible connection methods are "ftp", "http", "https" and +;; "smb". When one of these methods is added to the list, the remote +;; access for that method is performed via GVFS instead of the native +;; Tramp implementation. However, this is not recommended. These +;; methods are listed here for the benefit of file archives, see +;; tramp-archive.el. ;; GVFS offers even more connection methods. The complete list of ;; connection methods of the actual GVFS implementation can be @@ -66,28 +68,26 @@ ;; (message ;; "%s" ;; (mapcar -;; 'car +;; #'car ;; (dbus-call-method ;; :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker ;; tramp-gvfs-interface-mounttracker "ListMountableInfo"))) +;; See also /usr/share/gvfs/mounts + ;; Note that all other connection methods are not tested, beside the ;; ones offered for customization in `tramp-gvfs-methods'. If you ;; request an additional connection method to be supported, please ;; drop me a note. -;; For hostname completion, information is retrieved either from the -;; bluez daemon (for the "obex" method), the hal daemon (for the -;; "synce" method), or from the zeroconf daemon (for the "afp", "dav", -;; "davs", and "sftp" methods). The zeroconf daemon is pre-configured -;; to discover services in the "local" domain. If another domain -;; shall be used for discovering services, the custom option -;; `tramp-gvfs-zeroconf-domain' can be set accordingly. +;; For hostname completion, information is retrieved from the zeroconf +;; daemon (for the "afp", "dav", "davs", and "sftp" methods). The +;; zeroconf daemon is pre-configured to discover services in the +;; "local" domain. If another domain shall be used for discovering +;; services, the user option `tramp-gvfs-zeroconf-domain' can be set +;; accordingly. ;; Restrictions: - -;; * The current GVFS implementation does not allow writing on the -;; remote bluetooth device via OBEX. ;; ;; * Two shares of the same SMB server cannot be mounted in parallel. @@ -97,43 +97,69 @@ ;; option "--without-dbus". Declare used subroutines and variables. (declare-function dbus-get-unique-name "dbusbind.c") +(eval-when-compile (require 'cl-lib)) (require 'tramp) - (require 'dbus) (require 'url-parse) (require 'url-util) -(require 'zeroconf) ;; Pacify byte-compiler. (eval-when-compile (require 'custom)) +(declare-function zeroconf-init "zeroconf") +(declare-function zeroconf-list-service-types "zeroconf") +(declare-function zeroconf-list-services "zeroconf") +(declare-function zeroconf-service-host "zeroconf") +(declare-function zeroconf-service-port "zeroconf") +(declare-function zeroconf-service-txt "zeroconf") + +;; We don't call `dbus-ping', because this would load dbus.el. +(defconst tramp-gvfs-enabled + (ignore-errors + (and (featurep 'dbusbind) + (autoload 'zeroconf-init "zeroconf") + (tramp-compat-funcall 'dbus-get-unique-name :system) + (tramp-compat-funcall 'dbus-get-unique-name :session) + (or (tramp-compat-process-running-p "gvfs-fuse-daemon") + (tramp-compat-process-running-p "gvfsd-fuse")))) + "Non-nil when GVFS is available.") + ;;;###tramp-autoload (defcustom tramp-gvfs-methods - '("afp" "dav" "davs" "gdrive" "obex" "sftp" "synce") + '("afp" "dav" "davs" "gdrive" "nextcloud" "sftp") "List of methods for remote files, accessed with GVFS." :group 'tramp - :version "26.1" + :version "27.1" :type '(repeat (choice (const "afp") (const "dav") (const "davs") (const "ftp") (const "gdrive") - (const "obex") + (const "http") + (const "https") + (const "nextcloud") (const "sftp") - (const "smb") - (const "synce")))) + (const "smb")))) + +(defconst tramp-goa-methods '("gdrive" "nextcloud") + "List of methods which require registration at GNOME Online Accounts.") + +;; Remove GNOME Online Accounts methods if not supported. +(unless (and tramp-gvfs-enabled + (member tramp-goa-service (dbus-list-known-names :session))) + (dolist (method tramp-goa-methods) + (setq tramp-gvfs-methods (delete method tramp-gvfs-methods)))) ;; Add defaults for `tramp-default-user-alist' and `tramp-default-host-alist'. ;;;###tramp-autoload -(when (string-match "\\(.+\\)@\\(\\(?:gmail\\|googlemail\\)\\.com\\)" - user-mail-address) - (add-to-list 'tramp-default-user-alist - `("\\`gdrive\\'" nil ,(match-string 1 user-mail-address))) - (add-to-list 'tramp-default-host-alist - '("\\`gdrive\\'" nil ,(match-string 2 user-mail-address)))) -;;;###tramp-autoload -(add-to-list 'tramp-default-user-alist '("\\`synce\\'" nil nil)) +(tramp--with-startup + (when (string-match "\\(.+\\)@\\(\\(?:gmail\\|googlemail\\)\\.com\\)" + user-mail-address) + (add-to-list 'tramp-default-user-alist + `("\\`gdrive\\'" nil ,(match-string 1 user-mail-address))) + (add-to-list 'tramp-default-host-alist + '("\\`gdrive\\'" nil ,(match-string 2 user-mail-address))))) ;;;###tramp-autoload (defcustom tramp-gvfs-zeroconf-domain "local" @@ -146,9 +172,10 @@ ;; completion. ;;;###tramp-autoload (when (featurep 'dbusbind) - (dolist (elt tramp-gvfs-methods) - (unless (assoc elt tramp-methods) - (add-to-list 'tramp-methods (cons elt nil))))) + (tramp--with-startup + (dolist (elt tramp-gvfs-methods) + (unless (assoc elt tramp-methods) + (add-to-list 'tramp-methods (cons elt nil)))))) (defconst tramp-gvfs-path-tramp (concat dbus-path-emacs "/Tramp") "The preceding object path for own objects.") @@ -156,16 +183,6 @@ (defconst tramp-gvfs-service-daemon "org.gtk.vfs.Daemon" "The well known name of the GVFS daemon.") -;; We don't call `dbus-ping', because this would load dbus.el. -(defconst tramp-gvfs-enabled - (ignore-errors - (and (featurep 'dbusbind) - (tramp-compat-funcall 'dbus-get-unique-name :system) - (tramp-compat-funcall 'dbus-get-unique-name :session) - (or (tramp-compat-process-running-p "gvfs-fuse-daemon") - (tramp-compat-process-running-p "gvfsd-fuse")))) - "Non-nil when GVFS is available.") - (defconst tramp-gvfs-path-mounttracker "/org/gtk/vfs/mounttracker" "The object path of the GVFS daemon.") @@ -287,131 +304,161 @@ It has been changed in GVFS 1.14.") (defconst tramp-gvfs-password-anonymous-supported 16 "Operation supports anonymous users.") -(defconst tramp-bluez-service "org.bluez" - "The well known name of the BLUEZ service.") +;; For the time being, we just need org.goa.Account and org.goa.Files +;; interfaces. We document the other ones, just in case. -(defconst tramp-bluez-interface-manager "org.bluez.Manager" - "The manager interface of the BLUEZ daemon.") +;;;###tramp-autoload +(defconst tramp-goa-service "org.gnome.OnlineAccounts" + "The well known name of the GNOME Online Accounts service.") -;; <interface name='org.bluez.Manager'> -;; <method name='DefaultAdapter'> -;; <arg type='o' direction='out'/> -;; </method> -;; <method name='FindAdapter'> -;; <arg type='s' direction='in'/> -;; <arg type='o' direction='out'/> -;; </method> -;; <method name='ListAdapters'> -;; <arg type='ao' direction='out'/> -;; </method> -;; <signal name='AdapterAdded'> -;; <arg type='o'/> -;; </signal> -;; <signal name='AdapterRemoved'> -;; <arg type='o'/> -;; </signal> -;; <signal name='DefaultAdapterChanged'> -;; <arg type='o'/> -;; </signal> +(defconst tramp-goa-path "/org/gnome/OnlineAccounts" + "The object path of the GNOME Online Accounts.") + +(defconst tramp-goa-path-accounts (concat tramp-goa-path "/Accounts") + "The object path of the GNOME Online Accounts accounts.") + +(defconst tramp-goa-interface-documents "org.gnome.OnlineAccounts.Documents" + "The documents interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Documents'> ;; </interface> -(defconst tramp-bluez-interface-adapter "org.bluez.Adapter" - "The adapter interface of the BLUEZ daemon.") +(defconst tramp-goa-interface-printers "org.gnome.OnlineAccounts.Printers" + "The printers interface of the GNOME Online Accounts.") -;; <interface name='org.bluez.Adapter'> -;; <method name='GetProperties'> -;; <arg type='a{sv}' direction='out'/> -;; </method> -;; <method name='SetProperty'> -;; <arg type='s' direction='in'/> -;; <arg type='v' direction='in'/> -;; </method> -;; <method name='RequestMode'> -;; <arg type='s' direction='in'/> -;; </method> -;; <method name='ReleaseMode'/> -;; <method name='RequestSession'/> -;; <method name='ReleaseSession'/> -;; <method name='StartDiscovery'/> -;; <method name='StopDiscovery'/> -;; <method name='ListDevices'> -;; <arg type='ao' direction='out'/> -;; </method> -;; <method name='CreateDevice'> -;; <arg type='s' direction='in'/> -;; <arg type='o' direction='out'/> -;; </method> -;; <method name='CreatePairedDevice'> -;; <arg type='s' direction='in'/> -;; <arg type='o' direction='in'/> -;; <arg type='s' direction='in'/> -;; <arg type='o' direction='out'/> -;; </method> -;; <method name='CancelDeviceCreation'> -;; <arg type='s' direction='in'/> -;; </method> -;; <method name='RemoveDevice'> -;; <arg type='o' direction='in'/> -;; </method> -;; <method name='FindDevice'> -;; <arg type='s' direction='in'/> -;; <arg type='o' direction='out'/> -;; </method> -;; <method name='RegisterAgent'> -;; <arg type='o' direction='in'/> -;; <arg type='s' direction='in'/> +;; <interface name='org.gnome.OnlineAccounts.Printers'> +;; </interface> + +(defconst tramp-goa-interface-files "org.gnome.OnlineAccounts.Files" + "The files interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Files'> +;; <property type='b' name='AcceptSslErrors' access='read'/> +;; <property type='s' name='Uri' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-contacts "org.gnome.OnlineAccounts.Contacts" + "The contacts interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Contacts'> +;; <property type='b' name='AcceptSslErrors' access='read'/> +;; <property type='s' name='Uri' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-calendar "org.gnome.OnlineAccounts.Calendar" + "The calendar interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Calendar'> +;; <property type='b' name='AcceptSslErrors' access='read'/> +;; <property type='s' name='Uri' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-oauth2based "org.gnome.OnlineAccounts.OAuth2Based" + "The oauth2based interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.OAuth2Based'> +;; <method name='GetAccessToken'> +;; <arg type='s' name='access_token' direction='out'/> +;; <arg type='i' name='expires_in' direction='out'/> ;; </method> -;; <method name='UnregisterAgent'> -;; <arg type='o' direction='in'/> +;; <property type='s' name='ClientId' access='read'/> +;; <property type='s' name='ClientSecret' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-account "org.gnome.OnlineAccounts.Account" + "The account interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Account'> +;; <method name='Remove'/> +;; <method name='EnsureCredentials'> +;; <arg type='i' name='expires_in' direction='out'/> ;; </method> -;; <signal name='DeviceCreated'> -;; <arg type='o'/> -;; </signal> -;; <signal name='DeviceRemoved'> -;; <arg type='o'/> -;; </signal> -;; <signal name='DeviceFound'> -;; <arg type='s'/> -;; <arg type='a{sv}'/> -;; </signal> -;; <signal name='PropertyChanged'> -;; <arg type='s'/> -;; <arg type='v'/> -;; </signal> -;; <signal name='DeviceDisappeared'> -;; <arg type='s'/> -;; </signal> +;; <property type='s' name='ProviderType' access='read'/> +;; <property type='s' name='ProviderName' access='read'/> +;; <property type='s' name='ProviderIcon' access='read'/> +;; <property type='s' name='Id' access='read'/> +;; <property type='b' name='IsLocked' access='read'/> +;; <property type='b' name='IsTemporary' access='readwrite'/> +;; <property type='b' name='AttentionNeeded' access='read'/> +;; <property type='s' name='Identity' access='read'/> +;; <property type='s' name='PresentationIdentity' access='read'/> +;; <property type='b' name='MailDisabled' access='readwrite'/> +;; <property type='b' name='CalendarDisabled' access='readwrite'/> +;; <property type='b' name='ContactsDisabled' access='readwrite'/> +;; <property type='b' name='ChatDisabled' access='readwrite'/> +;; <property type='b' name='DocumentsDisabled' access='readwrite'/> +;; <property type='b' name='MapsDisabled' access='readwrite'/> +;; <property type='b' name='MusicDisabled' access='readwrite'/> +;; <property type='b' name='PrintersDisabled' access='readwrite'/> +;; <property type='b' name='PhotosDisabled' access='readwrite'/> +;; <property type='b' name='FilesDisabled' access='readwrite'/> +;; <property type='b' name='TicketingDisabled' access='readwrite'/> +;; <property type='b' name='TodoDisabled' access='readwrite'/> +;; <property type='b' name='ReadLaterDisabled' access='readwrite'/> ;; </interface> -;;;###tramp-autoload -(defcustom tramp-bluez-discover-devices-timeout 60 - "Defines seconds since last bluetooth device discovery before rescanning. -A value of 0 would require an immediate discovery during hostname -completion, nil means to use always cached values for discovered -devices." - :group 'tramp - :version "23.2" - :type '(choice (const nil) integer)) +(defconst tramp-goa-identity-regexp + (concat "^" "\\(" tramp-user-regexp "\\)?" + "@" "\\(" tramp-host-regexp "\\)?" + "\\(?:" ":""\\(" tramp-port-regexp "\\)" "\\)?") + "Regexp matching GNOME Online Accounts \"PresentationIdentity\" property.") + +(defconst tramp-goa-interface-mail "org.gnome.OnlineAccounts.Mail" + "The mail interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Mail'> +;; <property type='s' name='EmailAddress' access='read'/> +;; <property type='s' name='Name' access='read'/> +;; <property type='b' name='ImapSupported' access='read'/> +;; <property type='b' name='ImapAcceptSslErrors' access='read'/> +;; <property type='s' name='ImapHost' access='read'/> +;; <property type='b' name='ImapUseSsl' access='read'/> +;; <property type='b' name='ImapUseTls' access='read'/> +;; <property type='s' name='ImapUserName' access='read'/> +;; <property type='b' name='SmtpSupported' access='read'/> +;; <property type='b' name='SmtpAcceptSslErrors' access='read'/> +;; <property type='s' name='SmtpHost' access='read'/> +;; <property type='b' name='SmtpUseAuth' access='read'/> +;; <property type='b' name='SmtpAuthLogin' access='read'/> +;; <property type='b' name='SmtpAuthPlain' access='read'/> +;; <property type='b' name='SmtpAuthXoauth2' access='read'/> +;; <property type='b' name='SmtpUseSsl' access='read'/> +;; <property type='b' name='SmtpUseTls' access='read'/> +;; <property type='s' name='SmtpUserName' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-chat "org.gnome.OnlineAccounts.Chat" + "The chat interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Chat'> +;; </interface> -(defvar tramp-bluez-discovery nil - "Indicator for a running bluetooth device discovery. -It keeps the timestamp of last discovery.") +(defconst tramp-goa-interface-photos "org.gnome.OnlineAccounts.Photos" + "The photos interface of the GNOME Online Accounts.") -(defvar tramp-bluez-devices nil - "Alist of detected bluetooth devices. -Every entry is a list (NAME ADDRESS).") +;; <interface name='org.gnome.OnlineAccounts.Photos'> +;; </interface> -(defconst tramp-hal-service "org.freedesktop.Hal" - "The well known name of the HAL service.") +(defconst tramp-goa-path-manager (concat tramp-goa-path "/Manager") + "The object path of the GNOME Online Accounts manager.") -(defconst tramp-hal-path-manager "/org/freedesktop/Hal/Manager" - "The object path of the HAL daemon manager.") +(defconst tramp-goa-interface-documents "org.gnome.OnlineAccounts.Manager" + "The manager interface of the GNOME Online Accounts.") -(defconst tramp-hal-interface-manager "org.freedesktop.Hal.Manager" - "The manager interface of the HAL daemon.") +;; <interface name='org.gnome.OnlineAccounts.Manager'> +;; <method name='AddAccount'> +;; <arg type='s' name='provider' direction='in'/> +;; <arg type='s' name='identity' direction='in'/> +;; <arg type='s' name='presentation_identity' direction='in'/> +;; <arg type='a{sv}' name='credentials' direction='in'/> +;; <arg type='a{ss}' name='details' direction='in'/> +;; <arg type='o' name='account_object_path' direction='out'/> +;; </method> +;; </interface> -(defconst tramp-hal-interface-device "org.freedesktop.Hal.Device" - "The device interface of the HAL daemon.") +;; The basic structure for GNOME Online Accounts. We use a list :type, +;; in order to be compatible with Emacs 24 and 25. +(cl-defstruct (tramp-goa-name (:type list) :named) method user host port) ;; "gvfs-<command>" utilities have been deprecated in GVFS 1.31.1. We ;; must use "gio <command>" tool instead. @@ -421,11 +468,13 @@ Every entry is a list (NAME ADDRESS).") ("gvfs-ls" . "list") ("gvfs-mkdir" . "mkdir") ("gvfs-monitor-file" . "monitor") + ("gvfs-mount" . "mount") ("gvfs-move" . "move") ("gvfs-rm" . "remove") ("gvfs-trash" . "trash")) "List of cons cells, mapping \"gvfs-<command>\" to \"gio <command>\".") +;; <http://www.pygtk.org/docs/pygobject/gio-constants.html> (defconst tramp-gvfs-file-attributes '("name" "type" @@ -470,11 +519,18 @@ Every entry is a list (NAME ADDRESS).") ":[[:blank:]]+\\(.*\\)$") "Regexp to parse GVFS file system attributes with `gvfs-info'.") +(defconst tramp-gvfs-nextcloud-default-prefix "/remote.php/webdav" + "Default prefix for owncloud / nextcloud methods.") + +(defconst tramp-gvfs-nextcloud-default-prefix-regexp + (concat (regexp-quote tramp-gvfs-nextcloud-default-prefix) "$") + "Regexp of default prefix for owncloud / nextcloud methods.") + ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-gvfs-file-name-handler-alist - '((access-file . ignore) + '((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' performed by default handler. @@ -488,16 +544,17 @@ Every entry is a list (NAME ADDRESS).") . tramp-handle-directory-files-and-attributes) (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) + (exec-path . ignore) (expand-file-name . tramp-gvfs-handle-expand-file-name) (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . ignore) (file-attributes . tramp-gvfs-handle-file-attributes) - (file-directory-p . tramp-gvfs-handle-file-directory-p) + (file-directory-p . tramp-handle-file-directory-p) (file-equal-p . tramp-handle-file-equal-p) (file-executable-p . tramp-gvfs-handle-file-executable-p) (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) - (file-local-copy . tramp-gvfs-handle-file-local-copy) + (file-local-copy . tramp-handle-file-local-copy) (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) @@ -518,9 +575,8 @@ Every entry is a list (NAME ADDRESS).") (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-gvfs-handle-file-system-info) (file-truename . tramp-handle-file-truename) - (file-writable-p . tramp-gvfs-handle-file-writable-p) + (file-writable-p . tramp-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) - ;; `find-file-noselect' performed by default handler. ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) @@ -529,6 +585,7 @@ Every entry is a list (NAME ADDRESS).") (make-directory . tramp-gvfs-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-gvfs-handle-rename-file) @@ -541,10 +598,11 @@ Every entry is a list (NAME ADDRESS).") (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (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-gvfs-handle-write-region)) + (write-region . tramp-handle-write-region)) "Alist of handler functions for Tramp GVFS method. Operations not mentioned here will be handled by the default Emacs primitives.") @@ -564,7 +622,7 @@ Operations not mentioned here will be handled by the default Emacs primitives.") First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." (unless tramp-gvfs-enabled - (tramp-compat-user-error nil "Package `tramp-gvfs' not supported")) + (tramp-user-error nil "Package `tramp-gvfs' not supported")) (let ((fn (assoc operation tramp-gvfs-file-name-handler-alist))) (if fn (save-match-data (apply (cdr fn) args)) @@ -572,8 +630,9 @@ pass to the OPERATION." ;;;###tramp-autoload (when (featurep 'dbusbind) - (tramp-register-foreign-file-name-handler - 'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler)) + (tramp--with-startup + (tramp-register-foreign-file-name-handler + #'tramp-gvfs-file-name-p #'tramp-gvfs-file-name-handler))) ;; D-Bus helper function. @@ -601,12 +660,24 @@ Return nil for null BYTE-ARRAY." (cond ((and (consp message) (characterp (car message))) (format "%S" (tramp-gvfs-dbus-byte-array-to-string message))) + ((and (consp message) (atom (cdr message))) + (cons (tramp-gvfs-stringify-dbus-message (car message)) + (tramp-gvfs-stringify-dbus-message (cdr message)))) ((consp message) - (mapcar 'tramp-gvfs-stringify-dbus-message message)) + (mapcar #'tramp-gvfs-stringify-dbus-message message)) ((stringp message) (format "%S" message)) (t message))) +(defun tramp-dbus-function (vec func args) + "Apply a D-Bus function FUNC from dbus.el. +The call will be traced by Tramp with trace level 6." + (let (result) + (tramp-message vec 6 "%s" (cons func args)) + (setq result (apply func args)) + (tramp-message vec 6 "%s" result(tramp-gvfs-stringify-dbus-message result)) + result)) + (defmacro with-tramp-dbus-call-method (vec synchronous bus service path interface method &rest args) "Apply a D-Bus call on bus BUS. @@ -615,22 +686,34 @@ If SYNCHRONOUS is non-nil, the call is synchronously. Otherwise, it is an asynchronous call, with `ignore' as callback function. The other arguments have the same meaning as with `dbus-call-method' -or `dbus-call-method-asynchronously'. Additionally, the call -will be traced by Tramp with trace level 6." +or `dbus-call-method-asynchronously'." `(let ((func (if ,synchronous - 'dbus-call-method 'dbus-call-method-asynchronously)) + #'dbus-call-method #'dbus-call-method-asynchronously)) (args (append (list ,bus ,service ,path ,interface ,method) - (if ,synchronous (list ,@args) (list 'ignore ,@args)))) - result) - (tramp-message ,vec 6 "%s %s" func args) - (setq result (apply func args)) - (tramp-message ,vec 6 "%s" (tramp-gvfs-stringify-dbus-message result)) - result)) + (if ,synchronous (list ,@args) (list 'ignore ,@args))))) + (tramp-dbus-function ,vec func args))) (put 'with-tramp-dbus-call-method 'lisp-indent-function 2) (put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>")) +(defmacro with-tramp-dbus-get-all-properties + (vec bus service path interface) + "Return all properties of INTERFACE. +The call will be traced by Tramp with trace level 6." + ;; Check, that interface exists at object path. Retrieve properties. + `(when (member + ,interface + (tramp-dbus-function + ,vec #'dbus-introspect-get-interface-names + (list ,bus ,service ,path))) + (tramp-dbus-function + ,vec #'dbus-get-all-properties (list ,bus ,service ,path ,interface)))) + +(put 'with-tramp-dbus-get-all-properties 'lisp-indent-function 1) +(put 'with-tramp-dbus-get-all-properties 'edebug-form-spec '(form symbolp body)) +(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-get-all-properties\\>")) + (defvar tramp-gvfs-dbus-event-vector nil "Current Tramp file name to be used, as vector. It is needed when D-Bus signals or errors arrive, because there @@ -639,15 +722,10 @@ is no information where to trace the message.") (defun tramp-gvfs-dbus-event-error (event err) "Called when a D-Bus error message arrives, see `dbus-event-error-functions'." (when tramp-gvfs-dbus-event-vector - (tramp-message tramp-gvfs-dbus-event-vector 10 "%S" event) + (tramp-message tramp-gvfs-dbus-event-vector 6 "%S" event) (tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err)))) -;; `dbus-event-error-hooks' has been renamed to -;; `dbus-event-error-functions' in Emacs 24.3. -(add-hook - (if (boundp 'dbus-event-error-functions) - 'dbus-event-error-functions 'dbus-event-error-hooks) - 'tramp-gvfs-dbus-event-error) +(add-hook 'dbus-event-error-functions #'tramp-gvfs-dbus-event-error) ;; File name primitives. @@ -672,6 +750,7 @@ file names." (unless (memq op '(copy rename)) (error "Unknown operation `%s', must be `copy' or `rename'" op)) + (setq filename (file-truename filename)) (if (file-directory-p filename) (progn (copy-directory filename newname keep-date t) @@ -686,6 +765,8 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) (if (or (and equal-remote (tramp-get-connection-property v "direct-copy-failed" nil)) @@ -706,7 +787,7 @@ file names." v 0 (format "%s %s to %s" msg-operation filename newname) (unless (apply - 'tramp-gvfs-send-command v gvfs-operation + #'tramp-gvfs-send-command v gvfs-operation (append (and (eq op 'copy) (or keep-date preserve-uid-gid) '("--preserve")) @@ -735,13 +816,13 @@ file names." (when (and t1 (eq op 'rename)) (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname))) (when t2 (with-parsed-tramp-file-name newname nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)))))))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname)))))))) (defun tramp-gvfs-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -775,8 +856,8 @@ file names." (tramp-error v 'file-error "Couldn't delete non-empty %s" directory))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (unless (tramp-gvfs-send-command v (if (and trash delete-by-moving-to-trash) "gvfs-trash" "gvfs-rm") @@ -790,8 +871,8 @@ file names." (defun tramp-gvfs-handle-delete-file (filename &optional trash) "Like `delete-file' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (unless (tramp-gvfs-send-command v (if (and trash delete-by-moving-to-trash) "gvfs-trash" "gvfs-rm") @@ -806,12 +887,14 @@ file names." "Like `expand-file-name' for Tramp files." ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". (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 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)) + (tramp-run-real-handler #'expand-file-name (list name nil)) ;; Dissect NAME. (with-parsed-tramp-file-name name nil ;; If there is a default location, expand tilde. @@ -826,14 +909,14 @@ file names." (tramp-get-connection-property v "default-location" "~") nil t localname 1))) ;; Tilde expansion is not possible. - (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + (when (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) (tramp-error v 'file-error "Cannot expand tilde in file `%s'" name)) - (unless (tramp-run-real-handler 'file-name-absolute-p (list localname)) + (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) ;; We do not pass "/..". - (if (string-match "^\\(afp\\|davs?\\|smb\\)$" method) + (if (string-match-p "^\\(afp\\|davs?\\|smb\\)$" method) (when (string-match "^/[^/]+\\(/\\.\\./?\\)" localname) (setq localname (replace-match "/" t t localname 1))) (when (string-match "^/\\.\\./?" localname) @@ -844,89 +927,86 @@ file names." ;; No tilde characters in file name, do normal ;; `expand-file-name' (this does "/./" and "/../"). (tramp-make-tramp-file-name - method user domain host port - (tramp-run-real-handler 'expand-file-name (list localname)))))) + v (tramp-run-real-handler #'expand-file-name (list localname)))))) (defun tramp-gvfs-get-directory-attributes (directory) "Return GVFS attributes association list of all files in DIRECTORY." - (ignore-errors - ;; Don't modify `last-coding-system-used' by accident. - (let ((last-coding-system-used last-coding-system-used) - result) - (with-parsed-tramp-file-name directory nil - (with-tramp-file-property v localname "directory-attributes" - (tramp-message v 5 "directory gvfs attributes: %s" localname) - ;; Send command. - (tramp-gvfs-send-command - v "gvfs-ls" "-h" "-n" "-a" - (mapconcat 'identity tramp-gvfs-file-attributes ",") - (tramp-gvfs-url-file-name directory)) - ;; Parse output. - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (while (looking-at - (concat "^\\(.+\\)[[:blank:]]" - "\\([[:digit:]]+\\)[[:blank:]]" - "(\\(.+?\\))" - tramp-gvfs-file-attributes-with-gvfs-ls-regexp)) - (let ((item (list (cons "type" (match-string 3)) - (cons "standard::size" (match-string 2)) - (cons "name" (match-string 1))))) - (goto-char (1+ (match-end 3))) - (while (looking-at - (concat - tramp-gvfs-file-attributes-with-gvfs-ls-regexp - "\\(" tramp-gvfs-file-attributes-with-gvfs-ls-regexp - "\\|" "$" "\\)")) - (push (cons (match-string 1) (match-string 2)) item) - (goto-char (match-end 2))) - ;; Add display name as head. - (push - (cons (cdr (or (assoc "standard::display-name" item) - (assoc "name" item))) - (nreverse item)) - result)) - (forward-line))) - result))))) + ;; Don't modify `last-coding-system-used' by accident. + (let ((last-coding-system-used last-coding-system-used) + result) + (with-parsed-tramp-file-name directory nil + (with-tramp-file-property v localname "directory-attributes" + (tramp-message v 5 "directory gvfs attributes: %s" localname) + ;; Send command. + (tramp-gvfs-send-command + v "gvfs-ls" "-h" "-n" "-a" + (string-join tramp-gvfs-file-attributes ",") + (tramp-gvfs-url-file-name directory)) + ;; Parse output. + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (while (looking-at + (concat "^\\(.+\\)[[:blank:]]" + "\\([[:digit:]]+\\)[[:blank:]]" + "(\\(.+?\\))" + tramp-gvfs-file-attributes-with-gvfs-ls-regexp)) + (let ((item (list (cons "type" (match-string 3)) + (cons "standard::size" (match-string 2)) + (cons "name" (match-string 1))))) + (goto-char (1+ (match-end 3))) + (while (looking-at + (concat + tramp-gvfs-file-attributes-with-gvfs-ls-regexp + "\\(" tramp-gvfs-file-attributes-with-gvfs-ls-regexp + "\\|" "$" "\\)")) + (push (cons (match-string 1) (match-string 2)) item) + (goto-char (match-end 2))) + ;; Add display name as head. + (push + (cons (cdr (or (assoc "standard::display-name" item) + (assoc "name" item))) + (nreverse item)) + result)) + (forward-line))) + result)))) (defun tramp-gvfs-get-root-attributes (filename &optional file-system) "Return GVFS attributes association list of FILENAME. If FILE-SYSTEM is non-nil, return file system attributes." - (ignore-errors - ;; Don't modify `last-coding-system-used' by accident. - (let ((last-coding-system-used last-coding-system-used) - result) - (with-parsed-tramp-file-name filename nil - (with-tramp-file-property - v localname - (if file-system "file-system-attributes" "file-attributes") - (tramp-message - v 5 "file%s gvfs attributes: %s" - (if file-system " system" "") localname) - ;; Send command. - (if file-system - (tramp-gvfs-send-command - v "gvfs-info" "--filesystem" (tramp-gvfs-url-file-name filename)) + ;; Don't modify `last-coding-system-used' by accident. + (let ((last-coding-system-used last-coding-system-used) + result) + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property + v localname + (if file-system "file-system-attributes" "file-attributes") + (tramp-message + v 5 "file%s gvfs attributes: %s" + (if file-system " system" "") localname) + ;; Send command. + (if file-system (tramp-gvfs-send-command - v "gvfs-info" (tramp-gvfs-url-file-name filename))) - ;; Parse output. - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (while (re-search-forward - (if file-system - tramp-gvfs-file-system-attributes-regexp - tramp-gvfs-file-attributes-with-gvfs-info-regexp) - nil t) - (push (cons (match-string 1) (match-string 2)) result)) - result)))))) + v "gvfs-info" "--filesystem" (tramp-gvfs-url-file-name filename)) + (tramp-gvfs-send-command + v "gvfs-info" (tramp-gvfs-url-file-name filename))) + ;; Parse output. + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (while (re-search-forward + (if file-system + tramp-gvfs-file-system-attributes-regexp + tramp-gvfs-file-attributes-with-gvfs-info-regexp) + nil t) + (push (cons (match-string 1) (match-string 2)) result)) + result))))) (defun tramp-gvfs-get-file-attributes (filename) "Return GVFS attributes association list of FILENAME." (setq filename (directory-file-name (expand-file-name filename))) (with-parsed-tramp-file-name filename nil (setq localname (tramp-compat-file-name-unquote localname)) - (if (or (and (string-match "^\\(afp\\|davs?\\|smb\\)$" method) - (string-match "^/?\\([^/]+\\)$" localname)) + (if (or (and (string-match-p "^\\(afp\\|davs?\\|smb\\)$" method) + (string-match-p "^/?\\([^/]+\\)$" localname)) (string-equal localname "/")) (tramp-gvfs-get-root-attributes filename) (assoc @@ -936,135 +1016,133 @@ If FILE-SYSTEM is non-nil, return file system attributes." (defun tramp-gvfs-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." (unless id-format (setq id-format 'integer)) - (ignore-errors - (let ((attributes (tramp-gvfs-get-file-attributes filename)) - dirp res-symlink-target res-numlinks res-uid res-gid res-access - res-mod res-change res-size res-filemodes res-inode res-device) - (when attributes - ;; ... directory or symlink - (setq dirp (if (equal "directory" (cdr (assoc "type" attributes))) t)) + (let ((attributes (tramp-gvfs-get-file-attributes filename)) + dirp res-symlink-target res-numlinks res-uid res-gid res-access + res-mod res-change res-size res-filemodes res-inode res-device) + (when attributes + ;; ... directory or symlink + (setq dirp (if (equal "directory" (cdr (assoc "type" attributes))) t)) + (setq res-symlink-target + (cdr (assoc "standard::symlink-target" attributes))) + (when (stringp res-symlink-target) (setq res-symlink-target - (cdr (assoc "standard::symlink-target" attributes))) - ;; ... number links - (setq res-numlinks - (string-to-number - (or (cdr (assoc "unix::nlink" attributes)) "0"))) - ;; ... uid and gid - (setq res-uid - (if (eq id-format 'integer) - (string-to-number - (or (cdr (assoc "unix::uid" attributes)) - (format "%s" tramp-unknown-id-integer))) - (or (cdr (assoc "owner::user" attributes)) - (cdr (assoc "unix::uid" attributes)) - tramp-unknown-id-string))) - (setq res-gid - (if (eq id-format 'integer) - (string-to-number - (or (cdr (assoc "unix::gid" attributes)) - (format "%s" tramp-unknown-id-integer))) - (or (cdr (assoc "owner::group" attributes)) - (cdr (assoc "unix::gid" attributes)) - tramp-unknown-id-string))) - ;; ... last access, modification and change time - (setq res-access - (seconds-to-time - (string-to-number - (or (cdr (assoc "time::access" attributes)) "0")))) - (setq res-mod - (seconds-to-time - (string-to-number - (or (cdr (assoc "time::modified" attributes)) "0")))) - (setq res-change - (seconds-to-time - (string-to-number - (or (cdr (assoc "time::changed" attributes)) "0")))) - ;; ... size - (setq res-size - (string-to-number - (or (cdr (assoc "standard::size" attributes)) "0"))) - ;; ... file mode flags - (setq res-filemodes - (let ((n (cdr (assoc "unix::mode" attributes)))) - (if n - (tramp-file-mode-from-int (string-to-number n)) - (format - "%s%s%s%s------" - (if dirp "d" (if res-symlink-target "l" "-")) - (if (equal (cdr (assoc "access::can-read" attributes)) - "FALSE") - "-" "r") - (if (equal (cdr (assoc "access::can-write" attributes)) - "FALSE") - "-" "w") - (if (equal (cdr (assoc "access::can-execute" attributes)) - "FALSE") - "-" "x"))))) - ;; ... inode and device - (setq res-inode - (let ((n (cdr (assoc "unix::inode" attributes)))) - (if n - (string-to-number n) - (tramp-get-inode (tramp-dissect-file-name filename))))) - (setq res-device - (let ((n (cdr (assoc "unix::device" attributes)))) - (if n - (string-to-number n) - (tramp-get-device (tramp-dissect-file-name filename))))) - - ;; Return data gathered. - (list - ;; 0. t for directory, string (name linked to) for - ;; symbolic link, or nil. - (or dirp res-symlink-target) - ;; 1. Number of links to file. - res-numlinks - ;; 2. File uid. - res-uid - ;; 3. File gid. - res-gid - ;; 4. Last access time, as a list of integers. - ;; 5. Last modification time, likewise. - ;; 6. Last status change time, likewise. - res-access res-mod res-change - ;; 7. Size in bytes (-1, if number is out of range). - res-size - ;; 8. File modes. - res-filemodes - ;; 9. t if file's gid would change if file were deleted - ;; and recreated. - nil - ;; 10. Inode number. - res-inode - ;; 11. Device number. - res-device - ))))) - -(defun tramp-gvfs-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - (eq t (tramp-compat-file-attribute-type - (file-attributes (file-truename filename))))) + ;; Parse unibyte codes "\xNN". We assume they are + ;; non-ASCII codepoints in the range #x80 through #xff. + ;; Convert them to multibyte. + (decode-coding-string + (replace-regexp-in-string + "\\\\x\\([[:xdigit:]]\\{2\\}\\)" + (lambda (x) + (unibyte-string (string-to-number (match-string 1 x) 16))) + res-symlink-target) + 'utf-8))) + ;; ... number links + (setq res-numlinks + (string-to-number + (or (cdr (assoc "unix::nlink" attributes)) "0"))) + ;; ... uid and gid + (setq res-uid + (if (eq id-format 'integer) + (string-to-number + (or (cdr (assoc "unix::uid" attributes)) + (eval-when-compile + (format "%s" tramp-unknown-id-integer)))) + (or (cdr (assoc "owner::user" attributes)) + (cdr (assoc "unix::uid" attributes)) + tramp-unknown-id-string))) + (setq res-gid + (if (eq id-format 'integer) + (string-to-number + (or (cdr (assoc "unix::gid" attributes)) + (eval-when-compile + (format "%s" tramp-unknown-id-integer)))) + (or (cdr (assoc "owner::group" attributes)) + (cdr (assoc "unix::gid" attributes)) + tramp-unknown-id-string))) + ;; ... last access, modification and change time + (setq res-access + (seconds-to-time + (string-to-number + (or (cdr (assoc "time::access" attributes)) "0")))) + (setq res-mod + (seconds-to-time + (string-to-number + (or (cdr (assoc "time::modified" attributes)) "0")))) + (setq res-change + (seconds-to-time + (string-to-number + (or (cdr (assoc "time::changed" attributes)) "0")))) + ;; ... size + (setq res-size + (string-to-number + (or (cdr (assoc "standard::size" attributes)) "0"))) + ;; ... file mode flags + (setq res-filemodes + (let ((n (cdr (assoc "unix::mode" attributes)))) + (if n + (tramp-file-mode-from-int (string-to-number n)) + (format + "%s%s%s%s------" + (if dirp "d" (if res-symlink-target "l" "-")) + (if (equal (cdr (assoc "access::can-read" attributes)) + "FALSE") + "-" "r") + (if (equal (cdr (assoc "access::can-write" attributes)) + "FALSE") + "-" "w") + (if (equal (cdr (assoc "access::can-execute" attributes)) + "FALSE") + "-" "x"))))) + ;; ... inode and device + (setq res-inode + (let ((n (cdr (assoc "unix::inode" attributes)))) + (if n + (string-to-number n) + (tramp-get-inode (tramp-dissect-file-name filename))))) + (setq res-device + (let ((n (cdr (assoc "unix::device" attributes)))) + (if n + (string-to-number n) + (tramp-get-device (tramp-dissect-file-name filename))))) + + ;; Return data gathered. + (list + ;; 0. t for directory, string (name linked to) for + ;; symbolic link, or nil. + (or dirp res-symlink-target) + ;; 1. Number of links to file. + res-numlinks + ;; 2. File uid. + res-uid + ;; 3. File gid. + res-gid + ;; 4. Last access time, as a list of integers. + ;; 5. Last modification time, likewise. + ;; 6. Last status change time, likewise. + res-access res-mod res-change + ;; 7. Size in bytes (-1, if number is out of range). + res-size + ;; 8. File modes. + res-filemodes + ;; 9. t if file's gid would change if file were deleted + ;; and recreated. + nil + ;; 10. Inode number. + res-inode + ;; 11. Device number. + res-device + )))) (defun tramp-gvfs-handle-file-executable-p (filename) "Like `file-executable-p' for Tramp files." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-executable-p" - (tramp-check-cached-permissions v ?x)))) - -(defun tramp-gvfs-handle-file-local-copy (filename) - "Like `file-local-copy' for Tramp files." - (with-parsed-tramp-file-name filename nil - (unless (file-exists-p filename) - (tramp-error - v tramp-file-missing - "Cannot make local copy of non-existing file `%s'" filename)) - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) - tmpfile))) + (and (file-exists-p filename) + (tramp-check-cached-permissions v ?x))))) (defun tramp-gvfs-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (unless (save-match-data (string-match "/" filename)) + (unless (string-match-p "/" filename) (all-completions filename (with-parsed-tramp-file-name (expand-file-name directory) nil @@ -1080,9 +1158,10 @@ If FILE-SYSTEM is non-nil, return file system attributes." "Like `file-notify-add-watch' for Tramp files." (setq file-name (expand-file-name file-name)) (with-parsed-tramp-file-name file-name nil - ;; We cannot watch directories, because `gvfs-monitor-dir' is not - ;; supported for gvfs-mounted directories. - (when (file-directory-p file-name) + ;; TODO: We cannot watch directories, because `gio monitor' is not + ;; supported for gvfs-mounted directories. However, + ;; `file-notify-add-watch' uses directories. + (when (or (not (tramp-gvfs-gio-tool-p v)) (file-directory-p file-name)) (tramp-error v 'file-notify-error "Monitoring not supported for `%s'" file-name)) (let* ((default-directory (file-name-directory file-name)) @@ -1095,69 +1174,83 @@ If FILE-SYSTEM is non-nil, return file system attributes." '(created changed changes-done-hint moved deleted)) ((memq 'attribute-change flags) '(attribute-changed)))) (p (apply - 'start-process + #'start-process "gvfs-monitor" (generate-new-buffer " *gvfs-monitor*") - (if (tramp-gvfs-gio-tool-p v) - `("gio" "monitor" ,(tramp-gvfs-url-file-name file-name))) - `("gvfs-monitor-file" (tramp-gvfs-url-file-name file-name))))) + `("gio" "monitor" ,(tramp-gvfs-url-file-name file-name))))) (if (not (processp p)) (tramp-error v 'file-notify-error "Monitoring not supported for `%s'" file-name) (tramp-message - v 6 "Run `%s', %S" (mapconcat 'identity (process-command p) " ") p) - (tramp-set-connection-property p "vector" v) + v 6 "Run `%s', %S" (string-join (process-command p) " ") p) + (process-put p 'vector v) (process-put p 'events events) (process-put p 'watch-name localname) - (process-put p 'adjust-window-size-function 'ignore) + (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) - (set-process-filter p 'tramp-gvfs-monitor-file-process-filter) + (set-process-filter p #'tramp-gvfs-monitor-process-filter) + (set-process-sentinel p #'tramp-file-notify-process-sentinel) ;; There might be an error if the monitor is not supported. ;; Give the filter a chance to read the output. - (tramp-accept-process-output p 1) + (while (tramp-accept-process-output p 0)) (unless (process-live-p p) (tramp-error - v 'file-notify-error "Monitoring not supported for `%s'" file-name)) + p 'file-notify-error "Monitoring not supported for `%s'" file-name)) p)))) -(defun tramp-gvfs-monitor-file-process-filter (proc string) +(defun tramp-gvfs-monitor-process-filter (proc string) "Read output from \"gvfs-monitor-file\" and add corresponding \ file-notify events." - (let* ((rest-string (process-get proc 'rest-string)) + (let* ((events (process-get proc 'events)) + (rest-string (process-get proc 'rest-string)) (dd (with-current-buffer (process-buffer proc) default-directory)) (ddu (regexp-quote (tramp-gvfs-url-file-name dd)))) (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 (replace-regexp-in-string - "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string)) - (when (string-match "Monitoring not supported" string) + ;; Fix action names. + string (replace-regexp-in-string + "attributes changed" "attribute-changed" string) + string (replace-regexp-in-string + "changes done" "changes-done-hint" string) + string (replace-regexp-in-string + "renamed to" "moved" string)) + ;; https://bugs.launchpad.net/bugs/1742946 + (when + (string-match-p "Monitoring not supported\\|No locations given" string) (delete-process proc)) (while (string-match - (concat "^[\n\r]*" - "File Monitor Event:[\n\r]+" - "File = \\([^\n\r]+\\)[\n\r]+" - "Event = \\([^[:blank:]]+\\)[\n\r]+") + (eval-when-compile + (concat "^.+:" + "[[:space:]]\\(.+\\):" + "[[:space:]]" (regexp-opt tramp-gio-events t) + "\\([[:space:]]\\(.+\\)\\)?$")) string) + (let ((file (match-string 1 string)) - (action (intern-soft - (replace-regexp-in-string - "_" "-" (downcase (match-string 2 string)))))) + (file1 (match-string 4 string)) + (action (intern-soft (match-string 2 string)))) (setq string (replace-match "" nil nil string)) ;; File names are returned as URL paths. We must convert them. (when (string-match ddu file) (setq file (replace-match dd nil nil file))) - (while (string-match "%\\([0-9A-F]\\{2\\}\\)" file) - (setq file - (replace-match - (char-to-string (string-to-number (match-string 1 file) 16)) - nil nil file))) + (while (string-match-p "%\\([0-9A-F]\\{2\\}\\)" file) + (setq file (url-unhex-string file))) + (when (string-match ddu (or file1 "")) + (setq file1 (replace-match dd nil nil file1))) + (while (string-match-p "%\\([0-9A-F]\\{2\\}\\)" (or file1 "")) + (setq file1 (url-unhex-string file1))) + ;; Remove watch when file or directory to be watched is deleted. + (when (and (member action '(moved deleted)) + (string-equal file (process-get proc 'watch-name))) + (delete-process proc)) ;; Usually, we would add an Emacs event now. Unfortunately, ;; `unread-command-events' does not accept several events at ;; once. Therefore, we apply the callback directly. - (tramp-compat-funcall 'file-notify-callback (list proc action file)))) + (when (member action events) + (tramp-compat-funcall + 'file-notify-callback (list proc action file file1))))) ;; Save rest of the string. (when (zerop (length string)) (setq string nil)) @@ -1168,40 +1261,42 @@ file-notify events." "Like `file-readable-p' for Tramp files." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-readable-p" - (tramp-check-cached-permissions v ?r)))) + (and (file-exists-p filename) + (or (tramp-check-cached-permissions v ?r) + ;; If the user is different from what we guess to be + ;; the user, we don't know. Let's check, whether + ;; access is restricted explicitly. + (and (/= (tramp-gvfs-get-remote-uid v 'integer) + (tramp-compat-file-attribute-user-id + (file-attributes filename 'integer))) + (not + (string-equal + "FALSE" + (cdr (assoc + "access::can-read" + (tramp-gvfs-get-file-attributes filename))))))))))) (defun tramp-gvfs-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." (setq filename (directory-file-name (expand-file-name filename))) (with-parsed-tramp-file-name filename nil ;; We don't use cached values. - (tramp-set-file-property v localname "file-system-attributes" 'undef) + (tramp-flush-file-property v localname "file-system-attributes") (let* ((attr (tramp-gvfs-get-root-attributes filename 'file-system)) (size (cdr (assoc "filesystem::size" attr))) (used (cdr (assoc "filesystem::used" attr))) (free (cdr (assoc "filesystem::free" attr)))) (when (and (stringp size) (stringp used) (stringp free)) - (list (string-to-number (concat size "e0")) - (- (string-to-number (concat size "e0")) - (string-to-number (concat used "e0"))) - (string-to-number (concat free "e0"))))))) - -(defun tramp-gvfs-handle-file-writable-p (filename) - "Like `file-writable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-tramp-file-property v localname "file-writable-p" - (if (file-exists-p filename) - (tramp-check-cached-permissions v ?w) - ;; If file doesn't exist, check if directory is writable. - (and (file-directory-p (file-name-directory filename)) - (file-writable-p (file-name-directory filename))))))) + (list (string-to-number size) + (- (string-to-number size) (string-to-number used)) + (string-to-number free)))))) (defun tramp-gvfs-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." (setq dir (directory-file-name (expand-file-name dir))) (with-parsed-tramp-file-name dir nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (save-match-data (let ((ldir (file-name-directory dir))) ;; Make missing directory parts. "gvfs-mkdir -p ..." does not @@ -1228,56 +1323,14 @@ file-notify events." '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)))) - -(defun tramp-gvfs-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)) - - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (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 - ;; 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)) - (condition-case nil - (rename-file tmpfile filename 'ok-if-already-exists) - (error - (delete-file tmpfile) - (tramp-error - v 'file-error "Couldn't write region to `%s'" filename)))) - - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) - - ;; Set file modification time. - (when (or (eq visit t) (stringp visit)) - (set-visited-file-modtime - (tramp-compat-file-attribute-modification-time - (file-attributes filename)))) - - ;; 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))) + #'rename-file (list filename newname ok-if-already-exists)))) ;; File name conversions. (defun tramp-gvfs-url-file-name (filename) "Return FILENAME in URL syntax." - ;; "/" must NOT be hexlified. + ;; "/" must NOT be hexified. (setq filename (tramp-compat-file-name-unquote filename)) (let ((url-unreserved-chars (cons ?/ url-unreserved-chars)) result) @@ -1288,6 +1341,10 @@ file-notify events." (with-parsed-tramp-file-name filename nil (when (string-equal "gdrive" method) (setq method "google-drive")) + (when (string-equal "nextcloud" method) + (setq method "davs" + localname + (concat (tramp-gvfs-get-remote-prefix v) localname))) (when (and user domain) (setq user (concat domain ";" user))) (url-parse-make-urlobj @@ -1312,24 +1369,6 @@ file-notify events." (dbus-unescape-from-identifier (replace-regexp-in-string "^.*/\\([^/]+\\)$" "\\1" object-path))) -(defun tramp-bluez-address (device) - "Return bluetooth device address from a given bluetooth DEVICE name." - (when (stringp device) - (if (string-match tramp-ipv6-regexp device) - (match-string 0 device) - (cadr (assoc device (tramp-bluez-list-devices)))))) - -(defun tramp-bluez-device (address) - "Return bluetooth device name from a given bluetooth device ADDRESS. -ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." - (when (stringp address) - (while (string-match "[][]" address) - (setq address (replace-match "" t t address))) - (let (result) - (dolist (item (tramp-bluez-list-devices) result) - (when (string-match address (cadr item)) - (setq result (car item))))))) - ;; D-Bus GVFS functions. @@ -1361,13 +1400,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (unless (tramp-get-connection-property l "first-password-request" nil) (tramp-clear-passwd l)) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method l-method - tramp-current-user user - tramp-current-domain l-domain - tramp-current-host l-host - tramp-current-port l-port - password (tramp-read-passwd + (setq password (tramp-read-passwd (tramp-get-connection-process l) pw-prompt)) ;; Return result. @@ -1406,7 +1439,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (tramp-get-connection-process v) message ;; In theory, there can be several choices. ;; Until now, there is only the question whether - ;; to accept an unknown host signature. + ;; to accept an unknown host signature or certificate. (with-temp-buffer ;; Preserve message for `progress-reporter'. (with-temp-message "" @@ -1447,6 +1480,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (while (stringp (car elt)) (setq elt (cdr elt))) (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string (cadr elt))) (mount-spec (cl-caddr elt)) + (prefix (tramp-gvfs-dbus-byte-array-to-string (car mount-spec))) (default-location (tramp-gvfs-dbus-byte-array-to-string (cl-cadddr elt))) (method (tramp-gvfs-dbus-byte-array-to-string @@ -1462,53 +1496,56 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (cadr (assoc "port" (cadr mount-spec))))) (ssl (tramp-gvfs-dbus-byte-array-to-string (cadr (assoc "ssl" (cadr mount-spec))))) - (prefix (concat - (tramp-gvfs-dbus-byte-array-to-string - (car mount-spec)) - (tramp-gvfs-dbus-byte-array-to-string - (or (cadr (assoc "share" (cadr mount-spec))) - (cadr (assoc "volume" (cadr mount-spec)))))))) + (uri (tramp-gvfs-dbus-byte-array-to-string + (cadr (assoc "uri" (cadr mount-spec)))))) (when (string-match "^\\(afp\\|smb\\)" method) (setq method (match-string 1 method))) - (when (string-equal "obex" method) - (setq host (tramp-bluez-device host))) (when (and (string-equal "dav" method) (string-equal "true" ssl)) (setq method "davs")) + (when (and (string-equal "davs" method) + (string-match-p + tramp-gvfs-nextcloud-default-prefix-regexp prefix)) + (setq method "nextcloud")) (when (string-equal "google-drive" method) (setq method "gdrive")) - (with-parsed-tramp-file-name - (tramp-make-tramp-file-name method user domain host port "") nil - (tramp-message - v 6 "%s %s" - signal-name (tramp-gvfs-stringify-dbus-message mount-info)) - (tramp-set-file-property v "/" "list-mounts" 'undef) - (if (string-equal (downcase signal-name) "unmounted") - (tramp-flush-file-property v "/") - ;; Set prefix, mountpoint and location. - (unless (string-equal prefix "/") - (tramp-set-file-property v "/" "prefix" prefix)) - (tramp-set-file-property v "/" "fuse-mountpoint" fuse-mountpoint) - (tramp-set-connection-property - v "default-location" default-location))))))) + (when (and (string-equal "http" method) (stringp uri)) + (setq uri (url-generic-parse-url uri) + method (url-type uri) + user (url-user uri) + host (url-host uri) + port (url-portspec uri))) + (when (member method tramp-gvfs-methods) + (with-parsed-tramp-file-name + (tramp-make-tramp-file-name method user domain host port "") nil + (tramp-message + v 6 "%s %s" + signal-name (tramp-gvfs-stringify-dbus-message mount-info)) + (tramp-flush-file-property v "/" "list-mounts") + (if (string-equal (downcase signal-name) "unmounted") + (tramp-flush-file-properties v "/") + ;; Set mountpoint and location. + (tramp-set-file-property v "/" "fuse-mountpoint" fuse-mountpoint) + (tramp-set-connection-property + v "default-location" default-location)))))))) (when tramp-gvfs-enabled (dbus-register-signal :session nil tramp-gvfs-path-mounttracker tramp-gvfs-interface-mounttracker "mounted" - 'tramp-gvfs-handler-mounted-unmounted) + #'tramp-gvfs-handler-mounted-unmounted) (dbus-register-signal :session nil tramp-gvfs-path-mounttracker tramp-gvfs-interface-mounttracker "Mounted" - 'tramp-gvfs-handler-mounted-unmounted) + #'tramp-gvfs-handler-mounted-unmounted) (dbus-register-signal :session nil tramp-gvfs-path-mounttracker tramp-gvfs-interface-mounttracker "unmounted" - 'tramp-gvfs-handler-mounted-unmounted) + #'tramp-gvfs-handler-mounted-unmounted) (dbus-register-signal :session nil tramp-gvfs-path-mounttracker tramp-gvfs-interface-mounttracker "Unmounted" - 'tramp-gvfs-handler-mounted-unmounted)) + #'tramp-gvfs-handler-mounted-unmounted)) (defun tramp-gvfs-connection-mounted-p (vec) "Check, whether the location is already mounted." @@ -1529,6 +1566,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string (cadr elt))) (mount-spec (cl-caddr elt)) + (prefix (tramp-gvfs-dbus-byte-array-to-string (car mount-spec))) (default-location (tramp-gvfs-dbus-byte-array-to-string (cl-cadddr elt))) (method (tramp-gvfs-dbus-byte-array-to-string @@ -1544,43 +1582,59 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (cadr (assoc "port" (cadr mount-spec))))) (ssl (tramp-gvfs-dbus-byte-array-to-string (cadr (assoc "ssl" (cadr mount-spec))))) - (prefix (concat - (tramp-gvfs-dbus-byte-array-to-string - (car mount-spec)) - (tramp-gvfs-dbus-byte-array-to-string - (or - (cadr (assoc "share" (cadr mount-spec))) - (cadr (assoc "volume" (cadr mount-spec)))))))) + (uri (tramp-gvfs-dbus-byte-array-to-string + (cadr (assoc "uri" (cadr mount-spec))))) + (share (tramp-gvfs-dbus-byte-array-to-string + (or + (cadr (assoc "share" (cadr mount-spec))) + (cadr (assoc "volume" (cadr mount-spec))))))) (when (string-match "^\\(afp\\|smb\\)" method) (setq method (match-string 1 method))) - (when (string-equal "obex" method) - (setq host (tramp-bluez-device host))) (when (and (string-equal "dav" method) (string-equal "true" ssl)) (setq method "davs")) + (when (and (string-equal "davs" method) + (string-match-p + tramp-gvfs-nextcloud-default-prefix-regexp prefix)) + (setq method "nextcloud")) (when (string-equal "google-drive" method) (setq method "gdrive")) - (when (and (string-equal "synce" method) (zerop (length user))) - (setq user (or (tramp-file-name-user vec) ""))) + (when (and (string-equal "http" method) (stringp uri)) + (setq uri (url-generic-parse-url uri) + method (url-type uri) + user (url-user uri) + host (url-host uri) + port (url-portspec uri))) (when (and (string-equal method (tramp-file-name-method vec)) (string-equal user (tramp-file-name-user vec)) (string-equal domain (tramp-file-name-domain vec)) (string-equal host (tramp-file-name-host vec)) (string-equal port (tramp-file-name-port vec)) - (string-match (concat "^" (regexp-quote prefix)) - (tramp-file-name-unquote-localname vec))) - ;; Set prefix, mountpoint and location. - (unless (string-equal prefix "/") - (tramp-set-file-property vec "/" "prefix" prefix)) + (string-match-p (concat "^/" (regexp-quote (or share ""))) + (tramp-file-name-unquote-localname vec))) + ;; Set mountpoint and location. (tramp-set-file-property vec "/" "fuse-mountpoint" fuse-mountpoint) (tramp-set-connection-property vec "default-location" default-location) (throw 'mounted t))))))) +(defun tramp-gvfs-unmount (vec) + "Unmount the object identified by VEC." + (setf (tramp-file-name-localname vec) "/" + (tramp-file-name-hop vec) nil) + (when (tramp-gvfs-connection-mounted-p vec) + (tramp-gvfs-send-command + vec "gvfs-mount" "-u" + (tramp-gvfs-url-file-name (tramp-make-tramp-file-name vec)))) + (while (tramp-gvfs-connection-mounted-p vec) + (read-event nil nil 0.1)) + (tramp-flush-connection-properties vec) + (tramp-flush-connection-properties (tramp-get-connection-process vec))) + (defun tramp-gvfs-mount-spec-entry (key value) "Construct a mount-spec entry to be used in a mount_spec. It was \"a(say)\", but has changed to \"a{sv})\"." - (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature) + (if (string-match-p "^(aya{sv})" tramp-gvfs-mountlocation-signature) (list :dict-entry key (list :variant (tramp-gvfs-dbus-string-to-byte-array value))) (list :struct key (tramp-gvfs-dbus-string-to-byte-array value)))) @@ -1595,7 +1649,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (localname (tramp-file-name-unquote-localname vec)) (share (when (string-match "^/?\\([^/]+\\)" localname) (match-string 1 localname))) - (ssl (if (string-match "^davs" method) "true" "false")) + (ssl (if (string-match-p "^davs\\|^nextcloud" method) "true" "false")) (mount-spec `(:array ,@(cond @@ -1603,11 +1657,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (list (tramp-gvfs-mount-spec-entry "type" "smb-share") (tramp-gvfs-mount-spec-entry "server" host) (tramp-gvfs-mount-spec-entry "share" share))) - ((string-equal "obex" method) - (list (tramp-gvfs-mount-spec-entry "type" method) - (tramp-gvfs-mount-spec-entry - "host" (concat "[" (tramp-bluez-address host) "]")))) - ((string-match "\\`dav" method) + ((string-match-p "^dav\\|^nextcloud" method) (list (tramp-gvfs-mount-spec-entry "type" "dav") (tramp-gvfs-mount-spec-entry "host" host) (tramp-gvfs-mount-spec-entry "ssl" ssl))) @@ -1618,7 +1668,17 @@ It was \"a(say)\", but has changed to \"a{sv})\"." ((string-equal "gdrive" method) (list (tramp-gvfs-mount-spec-entry "type" "google-drive") (tramp-gvfs-mount-spec-entry "host" host))) - (t + ((string-equal "nextcloud" method) + (list (tramp-gvfs-mount-spec-entry "type" "owncloud") + (tramp-gvfs-mount-spec-entry "host" host))) + ((string-match-p "^http" method) + (list (tramp-gvfs-mount-spec-entry "type" "http") + (tramp-gvfs-mount-spec-entry + "uri" + (url-recreate-url + (url-parse-make-urlobj + method user nil host port "/" nil nil t))))) + (t (list (tramp-gvfs-mount-spec-entry "type" method) (tramp-gvfs-mount-spec-entry "host" host)))) ,@(when user @@ -1628,10 +1688,10 @@ It was \"a(say)\", but has changed to \"a{sv})\"." ,@(when port (list (tramp-gvfs-mount-spec-entry "port" port))))) (mount-pref - (if (and (string-match "\\`dav" method) + (if (and (string-match-p "^dav" method) (string-match "^/?[^/]+" localname)) (match-string 0 localname) - "/"))) + (tramp-gvfs-get-remote-prefix vec)))) ;; Return. `(:struct ,(tramp-gvfs-dbus-string-to-byte-array mount-pref) ,mount-spec))) @@ -1643,20 +1703,15 @@ It was \"a(say)\", but has changed to \"a{sv})\"." "The uid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." (with-tramp-connection-property vec (format "uid-%s" id-format) - (let ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (domain (tramp-file-name-domain vec)) - (host (tramp-file-name-host vec)) - (port (tramp-file-name-port vec)) + (let ((user (tramp-file-name-user vec)) (localname (tramp-get-connection-property vec "default-location" nil))) (cond - ((and user (equal id-format 'string)) user) + ((and (equal id-format 'string) user)) (localname (tramp-compat-file-attribute-user-id (file-attributes - (tramp-make-tramp-file-name method user domain host port localname) - id-format))) + (tramp-make-tramp-file-name vec localname) id-format))) ((equal id-format 'integer) tramp-unknown-id-integer) ((equal id-format 'string) tramp-unknown-id-string))))) @@ -1664,25 +1719,28 @@ ID-FORMAT valid values are `string' and `integer'." "The gid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." (with-tramp-connection-property vec (format "gid-%s" id-format) - (let ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (domain (tramp-file-name-domain vec)) - (host (tramp-file-name-host vec)) - (port (tramp-file-name-port vec)) - (localname + (let ((localname (tramp-get-connection-property vec "default-location" nil))) (cond (localname (tramp-compat-file-attribute-group-id (file-attributes - (tramp-make-tramp-file-name method user domain host port localname) - id-format))) + (tramp-make-tramp-file-name vec localname) id-format))) ((equal id-format 'integer) tramp-unknown-id-integer) ((equal id-format 'string) tramp-unknown-id-string))))) (defvar tramp-gvfs-get-remote-uid-gid-in-progress nil "Indication, that remote uid and gid determination is in progress.") +(defun tramp-gvfs-get-remote-prefix (vec) + "The prefix of the remote connection VEC. +This is relevant for GNOME Online Accounts." + (with-tramp-connection-property vec "prefix" + ;; Ensure that GNOME Online Accounts are cached. + (when (member (tramp-file-name-method vec) tramp-goa-methods) + (tramp-get-goa-accounts vec)) + (tramp-get-connection-property (tramp-make-goa-name vec) "prefix" "/"))) + (defun tramp-gvfs-maybe-open-connection (vec) "Maybe open a connection VEC. Does not do anything if a connection is already open, but re-opens the @@ -1696,33 +1754,40 @@ connection if a previous connection has died for some reason." ;; better solution? (unless (get-buffer-process (tramp-get-connection-buffer vec)) (let ((p (make-network-process - :name (tramp-buffer-name vec) + :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))) (unless (tramp-gvfs-connection-mounted-p vec) - (let* ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (domain (tramp-file-name-domain vec)) - (host (tramp-file-name-host vec)) - (port (tramp-file-name-port vec)) - (localname (tramp-file-name-unquote-localname vec)) - (object-path - (tramp-gvfs-object-path - (tramp-make-tramp-file-name method user domain host port "")))) + (let ((method (tramp-file-name-method vec)) + (user (tramp-file-name-user vec)) + (host (tramp-file-name-host vec)) + (localname (tramp-file-name-unquote-localname vec)) + (object-path + (tramp-gvfs-object-path (tramp-make-tramp-file-name vec 'noloc)))) (when (and (string-equal method "afp") (string-equal localname "/")) - (tramp-error vec 'file-error "Filename must contain an AFP volume")) + (tramp-user-error vec "Filename must contain an AFP volume")) - (when (and (string-match method "davs?") + (when (and (string-match-p "davs?" method) (string-equal localname "/")) - (tramp-error vec 'file-error "Filename must contain a WebDAV share")) + (tramp-user-error vec "Filename must contain a WebDAV share")) (when (and (string-equal method "smb") (string-equal localname "/")) - (tramp-error vec 'file-error "Filename must contain a Windows share")) + (tramp-user-error vec "Filename must contain a Windows share")) + + (when (member method tramp-goa-methods) + ;; Ensure that GNOME Online Accounts are cached. + (tramp-get-goa-accounts vec) + (when (tramp-get-connection-property + (tramp-make-goa-name vec) "FilesDisabled" t) + (tramp-user-error + vec "There is no Online Account `%s'" + (tramp-make-tramp-file-name vec 'noloc)))) (with-tramp-progress-reporter vec 3 @@ -1738,25 +1803,26 @@ connection if a previous connection has died for some reason." (dbus-register-method :session dbus-service-emacs object-path tramp-gvfs-interface-mountoperation "askPassword" - 'tramp-gvfs-handler-askpassword) + #'tramp-gvfs-handler-askpassword) (dbus-register-method :session dbus-service-emacs object-path tramp-gvfs-interface-mountoperation "AskPassword" - 'tramp-gvfs-handler-askpassword) + #'tramp-gvfs-handler-askpassword) - ;; There could be a callback of "askQuestion" when adding fingerprint. + ;; There could be a callback of "askQuestion" when adding + ;; fingerprints or checking certificates. (dbus-register-method :session dbus-service-emacs object-path tramp-gvfs-interface-mountoperation "askQuestion" - 'tramp-gvfs-handler-askquestion) + #'tramp-gvfs-handler-askquestion) (dbus-register-method :session dbus-service-emacs object-path tramp-gvfs-interface-mountoperation "AskQuestion" - 'tramp-gvfs-handler-askquestion) + #'tramp-gvfs-handler-askquestion) ;; The call must be asynchronously, because of the "askPassword" ;; or "askQuestion" callbacks. - (if (string-match "(so)$" tramp-gvfs-mountlocation-signature) + (if (string-match-p "(so)$" tramp-gvfs-mountlocation-signature) (with-tramp-dbus-call-method vec nil :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation @@ -1791,6 +1857,9 @@ connection if a previous connection has died for some reason." (tramp-get-file-property vec "/" "fuse-mountpoint" "") "/") (tramp-error vec 'file-error "FUSE mount denied")) + ;; Save the password. + (ignore-errors (funcall tramp-password-save-function)) + ;; Set connection-local variables. (tramp-set-connection-local-variables vec) @@ -1799,7 +1868,7 @@ connection if a previous connection has died for some reason." (tramp-get-connection-process vec) "connected" t)))) ;; In `tramp-check-cached-permissions', the connection properties - ;; {uig,gid}-{integer,string} are used. We set them to proper values. + ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. (unless tramp-gvfs-get-remote-uid-gid-in-progress (let ((tramp-gvfs-get-remote-uid-gid-in-progress t)) (tramp-gvfs-get-remote-uid vec 'integer) @@ -1832,88 +1901,78 @@ is applied, and it returns t if the return code is zero." (with-current-buffer (tramp-get-connection-buffer vec) (tramp-gvfs-maybe-open-connection vec) (erase-buffer) - (or (zerop (apply 'tramp-call-process vec command nil t nil args)) + (or (zerop (apply #'tramp-call-process vec command nil t nil args)) ;; Remove information about mounted connection. - (and (tramp-flush-file-property vec "/") nil))))) + (and (tramp-flush-file-properties vec "/") nil))))) -;; D-Bus BLUEZ functions. - -(defun tramp-bluez-list-devices () - "Return all discovered bluetooth devices as list. -Every entry is a list (NAME ADDRESS). - -If `tramp-bluez-discover-devices-timeout' is an integer, and the last -discovery happened more time before indicated there, a rescan will be -started, which lasts some ten seconds. Otherwise, cached results will -be used." - ;; Reset the scanned devices list if time has passed. - (and (integerp tramp-bluez-discover-devices-timeout) - (integerp tramp-bluez-discovery) - (> (tramp-time-diff (current-time) tramp-bluez-discovery) - tramp-bluez-discover-devices-timeout) - (setq tramp-bluez-devices nil)) - - ;; Rescan if needed. - (unless tramp-bluez-devices - (let ((object-path - (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t - :system tramp-bluez-service "/" - tramp-bluez-interface-manager "DefaultAdapter"))) - (setq tramp-bluez-devices nil - tramp-bluez-discovery t) - (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector nil - :system tramp-bluez-service object-path - tramp-bluez-interface-adapter "StartDiscovery") - (while tramp-bluez-discovery - (read-event nil nil 0.1)))) - (setq tramp-bluez-discovery (current-time)) - (tramp-message tramp-gvfs-dbus-event-vector 10 "%s" tramp-bluez-devices) - tramp-bluez-devices) - -(defun tramp-bluez-property-changed (property value) - "Signal handler for the \"org.bluez.Adapter.PropertyChanged\" signal." - (tramp-message tramp-gvfs-dbus-event-vector 6 "%s %s" property value) - (cond - ((string-equal property "Discovering") - (unless (car value) - ;; "Discovering" FALSE means discovery run has been completed. - ;; We stop it, because we don't need another run. - (setq tramp-bluez-discovery nil) - (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t - :system tramp-bluez-service (dbus-event-path-name last-input-event) - tramp-bluez-interface-adapter "StopDiscovery"))))) - -(when tramp-gvfs-enabled - (dbus-register-signal - :system nil nil tramp-bluez-interface-adapter "PropertyChanged" - 'tramp-bluez-property-changed)) - -(defun tramp-bluez-device-found (device args) - "Signal handler for the \"org.bluez.Adapter.DeviceFound\" signal." - (tramp-message tramp-gvfs-dbus-event-vector 6 "%s %s" device args) - (let ((alias (car (cadr (assoc "Alias" args)))) - (address (car (cadr (assoc "Address" args))))) - ;; Maybe we shall check the device class for being a proper - ;; device, and call also SDP in order to find the obex service. - (add-to-list 'tramp-bluez-devices (list alias address)))) - -(when tramp-gvfs-enabled - (dbus-register-signal - :system nil nil tramp-bluez-interface-adapter "DeviceFound" - 'tramp-bluez-device-found)) - -(defun tramp-bluez-parse-device-names (_ignore) - "Return a list of (nil host) tuples allowed to access." - (mapcar - (lambda (x) (list nil (car x))) - (tramp-bluez-list-devices))) - -;; Add completion function for OBEX method. -(when (and tramp-gvfs-enabled - (member tramp-bluez-service (dbus-list-known-names :system))) - (tramp-set-completion-function - "obex" '((tramp-bluez-parse-device-names "")))) +;; D-Bus GNOME Online Accounts functions. + +(defun tramp-make-goa-name (vec) + "Transform VEC into a `tramp-goa-name' structure." + (when (tramp-file-name-p vec) + (make-tramp-goa-name + :method (tramp-file-name-method vec) + :user (tramp-file-name-user vec) + :host (tramp-file-name-host vec) + :port (tramp-file-name-port vec)))) + +(defun tramp-get-goa-accounts (vec) + "Retrieve GNOME Online Accounts, and cache them. +The hash key is a `tramp-goa-name' structure. The value is an +alist of the properties of `tramp-goa-interface-account' and +`tramp-goa-interface-files' of the corresponding GNOME online +account. Additionally, a property \"prefix\" is added. +VEC is used only for traces." + (with-tramp-connection-property (tramp-make-goa-name vec) "goa-accounts" + (dolist + (object-path + (mapcar + #'car + (tramp-dbus-function + vec #'dbus-get-all-managed-objects + `(:session ,tramp-goa-service ,tramp-goa-path)))) + (let* ((account-properties + (with-tramp-dbus-get-all-properties vec + :session tramp-goa-service object-path + tramp-goa-interface-account)) + (files-properties + (with-tramp-dbus-get-all-properties vec + :session tramp-goa-service object-path + tramp-goa-interface-files)) + (identity + (or (cdr (assoc "PresentationIdentity" account-properties)) "")) + key) + ;; Only accounts which matter. + (when (and + (not (cdr (assoc "FilesDisabled" account-properties))) + (member + (cdr (assoc "ProviderType" account-properties)) + '("google" "owncloud")) + (string-match tramp-goa-identity-regexp identity)) + (setq key (make-tramp-goa-name + :method (cdr (assoc "ProviderType" account-properties)) + :user (match-string 1 identity) + :host (match-string 2 identity) + :port (match-string 3 identity))) + (when (string-equal (tramp-goa-name-method key) "google") + (setf (tramp-goa-name-method key) "gdrive")) + (when (string-equal (tramp-goa-name-method key) "owncloud") + (setf (tramp-goa-name-method key) "nextcloud")) + ;; Cache all properties. + (dolist (prop (nconc account-properties files-properties)) + (tramp-set-connection-property key (car prop) (cdr prop))) + ;; Cache "prefix". + (tramp-message + vec 10 "%s prefix %s" key + (tramp-set-connection-property + key "prefix" + (directory-file-name + (url-filename + (url-generic-parse-url + (tramp-get-connection-property key "Uri" "file:///"))))))))) + ;; Mark, that goa accounts have been cached. + "cached")) ;; D-Bus zeroconf functions. @@ -1936,15 +1995,12 @@ be used." (list user host))) (zeroconf-list-services service))) -;; We use the TRIM argument of `split-string', which exist since Emacs -;; 24.4. I mask this for older Emacs versions, there is no harm. (defun tramp-gvfs-parse-device-names (service) "Return a list of (user host) tuples allowed to access. This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." (let ((result (ignore-errors - (tramp-compat-funcall - 'split-string + (split-string (shell-command-to-string (format "avahi-browse -trkp %s" service)) "[\n\r]+" 'omit "^\\+;.*$")))) (delete-dups @@ -1952,8 +2008,7 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." (lambda (x) (let* ((list (split-string x ";")) (host (nth 6 list)) - (text (tramp-compat-funcall - 'split-string (nth 9 list) "\" \"" 'omit "\"")) + (text (split-string (nth 9 list) "\" \"" 'omit "\"")) user) ;; A user is marked in a TXT field like "u=guest". (while text @@ -1997,41 +2052,6 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." (tramp-set-completion-function "smb" '((tramp-gvfs-parse-device-names "_smb._tcp")))))))) - -;; D-Bus SYNCE functions. - -(defun tramp-synce-list-devices () - "Return all discovered synce devices as list. -They are retrieved from the hal daemon." - (let (tramp-synce-devices) - (dolist (device - (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t - :system tramp-hal-service tramp-hal-path-manager - tramp-hal-interface-manager "GetAllDevices")) - (when (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t - :system tramp-hal-service device tramp-hal-interface-device - "PropertyExists" "sync.plugin") - (let ((prop - (with-tramp-dbus-call-method - tramp-gvfs-dbus-event-vector t - :system tramp-hal-service device tramp-hal-interface-device - "GetPropertyString" "pda.pocketpc.name"))) - (unless (member prop tramp-synce-devices) - (push prop tramp-synce-devices))))) - (tramp-message tramp-gvfs-dbus-event-vector 10 "%s" tramp-synce-devices) - tramp-synce-devices)) - -(defun tramp-synce-parse-device-names (_ignore) - "Return a list of (nil host) tuples allowed to access." - (mapcar - (lambda (x) (list nil x)) - (tramp-synce-list-devices))) - -;; Add completion function for SYNCE method. -(when tramp-gvfs-enabled - (tramp-set-completion-function - "synce" '((tramp-synce-parse-device-names "")))) - (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-gvfs 'force))) @@ -2040,15 +2060,14 @@ They are retrieved from the hal daemon." ;;; TODO: +;; * (Customizable) unmount when exiting Emacs. See tramp-archive.el. +;; ;; * Host name completion for existing mount points (afp-server, -;; smb-server) or via smb-network. +;; smb-server, google-drive, nextcloud) or via smb-network or network. ;; ;; * Check, how two shares of the same SMB server can be mounted in ;; parallel. ;; -;; * Apply SDP on bluetooth devices, in order to filter out obex -;; capability. -;; -;; * Implement obex for other serial communication but bluetooth. +;; * What's up with ftps dns-sd afc admin computer? ;;; tramp-gvfs.el ends here diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el new file mode 100644 index 00000000000..0c706da1ca1 --- /dev/null +++ b/lisp/net/tramp-integration.el @@ -0,0 +1,196 @@ +;;; tramp-integration.el --- Tramp integration into other packages -*- lexical-binding:t -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This assembles all integration of Tramp with other packages. + +;;; Code: + +(require 'tramp-compat) + +;; Pacify byte-compiler. +(require 'cl-lib) +(declare-function recentf-cleanup "recentf") +(declare-function tramp-dissect-file-name "tramp") +(declare-function tramp-file-name-equal-p "tramp") +(declare-function tramp-tramp-file-p "tramp") +(defvar eshell-path-env) +(defvar recentf-exclude) +(defvar tramp-current-connection) +(defvar tramp-postfix-host-format) + +;;; Fontification of `read-file-name': + +(defvar tramp-rfn-eshadow-overlay) +(make-variable-buffer-local 'tramp-rfn-eshadow-overlay) + +(defun tramp-rfn-eshadow-setup-minibuffer () + "Set up a minibuffer for `file-name-shadow-mode'. +Adds another overlay hiding filename parts according to Tramp's +special handling of `substitute-in-file-name'." + (when minibuffer-completing-file-name + (setq tramp-rfn-eshadow-overlay + (make-overlay (minibuffer-prompt-end) (minibuffer-prompt-end))) + ;; Copy rfn-eshadow-overlay properties. + (let ((props (overlay-properties rfn-eshadow-overlay))) + (while props + ;; The `field' property prevents correct minibuffer + ;; completion; we exclude it. + (if (not (eq (car props) 'field)) + (overlay-put tramp-rfn-eshadow-overlay (pop props) (pop props)) + (pop props) (pop props)))))) + +(add-hook 'rfn-eshadow-setup-minibuffer-hook + #'tramp-rfn-eshadow-setup-minibuffer) +(add-hook 'tramp-unload-hook + (lambda () + (remove-hook 'rfn-eshadow-setup-minibuffer-hook + #'tramp-rfn-eshadow-setup-minibuffer))) + +(defun tramp-rfn-eshadow-update-overlay-regexp () + (format "[^%s/~]*\\(/\\|~\\)" tramp-postfix-host-format)) + +;; Package rfn-eshadow is preloaded in Emacs, but for some reason, +;; it only did (defvar rfn-eshadow-overlay) without giving it a global +;; value, so it was only declared as dynamically-scoped within the +;; rfn-eshadow.el file. This is now fixed in Emacs>26.1 but we still need +;; this defvar here for older releases. +(defvar rfn-eshadow-overlay) + +(defun tramp-rfn-eshadow-update-overlay () + "Update `rfn-eshadow-overlay' to cover shadowed part of minibuffer input. +This is intended to be used as a minibuffer `post-command-hook' for +`file-name-shadow-mode'; the minibuffer should have already +been set up by `rfn-eshadow-setup-minibuffer'." + ;; In remote files name, there is a shadowing just for the local part. + (ignore-errors + (let ((end (or (overlay-end rfn-eshadow-overlay) + (minibuffer-prompt-end))) + ;; We do not want to send any remote command. + (non-essential t)) + (when (tramp-tramp-file-p (buffer-substring end (point-max))) + (save-excursion + (save-restriction + (narrow-to-region + (1+ (or (string-match-p + (tramp-rfn-eshadow-update-overlay-regexp) + (buffer-string) end) + end)) + (point-max)) + (let ((rfn-eshadow-overlay tramp-rfn-eshadow-overlay) + (rfn-eshadow-update-overlay-hook nil) + file-name-handler-alist) + (move-overlay rfn-eshadow-overlay (point-max) (point-max)) + (rfn-eshadow-update-overlay)))))))) + +(add-hook 'rfn-eshadow-update-overlay-hook + #'tramp-rfn-eshadow-update-overlay) +(add-hook 'tramp-unload-hook + (lambda () + (remove-hook 'rfn-eshadow-update-overlay-hook + #'tramp-rfn-eshadow-update-overlay))) + +;;; Integration of eshell.el: + +;; eshell.el keeps the path in `eshell-path-env'. We must change it +;; when `default-directory' points to another host. +(defun tramp-eshell-directory-change () + "Set `eshell-path-env' to $PATH of the host related to `default-directory'." + ;; Remove last element of `(exec-path)', which is `exec-directory'. + ;; Use `path-separator' as it does eshell. + (setq eshell-path-env + (mapconcat + #'identity (butlast (tramp-compat-exec-path)) path-separator))) + +(with-eval-after-load 'esh-util + (add-hook 'eshell-mode-hook + #'tramp-eshell-directory-change) + (add-hook 'eshell-directory-change-hook + #'tramp-eshell-directory-change) + (add-hook 'tramp-integration-unload-hook + (lambda () + (remove-hook 'eshell-mode-hook + #'tramp-eshell-directory-change) + (remove-hook 'eshell-directory-change-hook + #'tramp-eshell-directory-change)))) + +;;; Integration of recentf.el: + +(defun tramp-recentf-exclude-predicate (name) + "Predicate to exclude a remote file name from recentf. +NAME must be equal to `tramp-current-connection'." + (when (file-remote-p name) + (tramp-file-name-equal-p + (tramp-dissect-file-name name) (car tramp-current-connection)))) + +(defun tramp-recentf-cleanup (vec) + "Remove all file names related to VEC from recentf." + (when (bound-and-true-p recentf-list) + (let ((tramp-current-connection `(,vec)) + (recentf-exclude '(tramp-recentf-exclude-predicate))) + (recentf-cleanup)))) + +(defun tramp-recentf-cleanup-all () + "Remove all remote file names from recentf." + (when (bound-and-true-p recentf-list) + (let ((recentf-exclude '(file-remote-p))) + (recentf-cleanup)))) + +(with-eval-after-load 'recentf + (add-hook 'tramp-cleanup-connection-hook + #'tramp-recentf-cleanup) + (add-hook 'tramp-cleanup-all-connections-hook + #'tramp-recentf-cleanup-all) + (add-hook 'tramp-integration-unload-hook + (lambda () + (remove-hook 'tramp-cleanup-connection-hook + #'tramp-recentf-cleanup) + (remove-hook 'tramp-cleanup-all-connections-hook + #'tramp-recentf-cleanup-all)))) + +;;; Default connection-local variables for Tramp: + +(defconst tramp-connection-local-default-profile + '((shell-file-name . "/bin/sh") + (shell-command-switch . "-c")) + "Default connection-local variables for remote connections.") + +;; `connection-local-set-profile-variables' and +;; `connection-local-set-profiles' exists since Emacs 26.1. +(with-eval-after-load 'shell + (tramp-compat-funcall + 'connection-local-set-profile-variables + 'tramp-connection-local-default-profile + tramp-connection-local-default-profile) + (tramp-compat-funcall + 'connection-local-set-profiles + `(:application tramp) + 'tramp-connection-local-default-profile)) + +(add-hook 'tramp-unload-hook + (lambda () (unload-feature 'tramp-integration 'force))) + +(provide 'tramp-integration) + +;;; tramp-integration.el ends here diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el new file mode 100644 index 00000000000..9b3eab34771 --- /dev/null +++ b/lisp/net/tramp-rclone.el @@ -0,0 +1,611 @@ +;;; tramp-rclone.el --- Tramp access functions to cloud storages -*- lexical-binding:t -*- + +;; Copyright (C) 2018-2019 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; rclone is a command line program to sync files and directories to +;; and from cloud storages. Tramp uses its mount utility to access +;; files and directories there. The configuration of rclone for +;; different storage systems is performed outside Tramp, see rclone(1). + +;; A remote file under rclone control has the form +;; "/rclone:<remote>:/path/to/file". <remote> is the name of a +;; storage system in rclone's configuration. Therefore, such a remote +;; file name does not know of any user or port specification. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'tramp) + +;;;###tramp-autoload +(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 + :version "27.1" + :type 'string) + +;;;###tramp-autoload +(tramp--with-startup + (add-to-list 'tramp-methods + `(,tramp-rclone-method + (tramp-mount-args nil) + (tramp-copyto-args nil) + (tramp-moveto-args nil) + (tramp-about-args ("--full")))) + + (add-to-list 'tramp-default-host-alist `(,tramp-rclone-method nil "")) + + (tramp-set-completion-function + tramp-rclone-method '((tramp-rclone-parse-device-names "")))) + + +;; New handlers should be added here. +;;;###tramp-autoload +(defconst tramp-rclone-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' performed by default handler. + (copy-file . tramp-rclone-handle-copy-file) + (delete-directory . tramp-rclone-handle-delete-directory) + (delete-file . tramp-rclone-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-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-rclone-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-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-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-rclone-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-rclone-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-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-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-rclone-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-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-handle-write-region)) + "Alist of handler functions for Tramp RCLONE 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-rclone-file-name-p (filename) + "Check if it's a filename for rclone." + (and (tramp-tramp-file-p filename) + (string= (tramp-file-name-method (tramp-dissect-file-name filename)) + tramp-rclone-method))) + +;;;###tramp-autoload +(defun tramp-rclone-file-name-handler (operation &rest args) + "Invoke the rclone handler for OPERATION. +First arg specifies the OPERATION, second arg is a list of arguments to +pass to the OPERATION." + (let ((fn (assoc operation tramp-rclone-file-name-handler-alist))) + (if fn + (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-rclone-file-name-p #'tramp-rclone-file-name-handler)) + +;;;###tramp-autoload +(defun tramp-rclone-parse-device-names (_ignore) + "Return a list of (nil host) tuples allowed to access." + (with-tramp-connection-property nil "rclone-device-names" + (delq nil + (mapcar + (lambda (line) + (when (string-match "^\\(\\S-+\\):$" line) + `(nil ,(match-string 1 line)))) + (tramp-process-lines nil tramp-rclone-program "listremotes"))))) + + +;; File name primitives. + +(defun tramp-rclone-do-copy-or-rename-file + (op filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Copy or rename a remote file. +OP must be `copy' or `rename' and indicates the operation to perform. +FILENAME specifies the file to copy or rename, NEWNAME is the name of +the new file (for copy) or the new name of the file (for rename). +OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already. +KEEP-DATE means to make sure that NEWNAME has the same timestamp +as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep +the uid and gid if both files are on the same host. +PRESERVE-EXTENDED-ATTRIBUTES is ignored. + +This function is invoked by `tramp-rclone-handle-copy-file' and +`tramp-rclone-handle-rename-file'. It is an error if OP is neither +of `copy' and `rename'. FILENAME and NEWNAME must be absolute +file names." + (unless (memq op '(copy rename)) + (error "Unknown operation `%s', must be `copy' or `rename'" op)) + + (setq filename (file-truename filename)) + (if (file-directory-p filename) + (progn + (copy-directory filename newname keep-date t) + (when (eq op 'rename) (delete-directory filename 'recursive))) + + (let ((t1 (tramp-tramp-file-p filename)) + (t2 (tramp-tramp-file-p newname)) + (rclone-operation (if (eq op 'copy) "copyto" "moveto")) + (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) + + (with-parsed-tramp-file-name (if t1 filename newname) nil + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (if (or (and t1 (not (tramp-rclone-file-name-p filename))) + (and t2 (not (tramp-rclone-file-name-p newname)))) + + ;; We cannot copy or rename directly. + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (if (eq op 'copy) + (copy-file + filename tmpfile t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file filename tmpfile t)) + (rename-file tmpfile newname ok-if-already-exists)) + + ;; Direct action. + (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) + (unless (zerop + (tramp-rclone-send-command + v rclone-operation + (tramp-rclone-remote-file-name filename) + (tramp-rclone-remote-file-name newname))) + (tramp-error + v 'file-error + "Error %s `%s' `%s'" msg-operation filename newname))) + + (when (and t1 (eq op 'rename)) + (with-parsed-tramp-file-name filename v1 + (tramp-flush-file-properties + v1 (file-name-directory v1-localname)) + (tramp-flush-file-properties v1 v1-localname) + (when (tramp-rclone-file-name-p filename) + (tramp-rclone-flush-directory-cache v1) + ;; The mount point's directory cache might need time + ;; to flush. + (while (file-exists-p filename) + (tramp-flush-file-properties + v1 (file-name-directory v1-localname)) + (tramp-flush-file-properties v1 v1-localname))))) + + (when t2 + (with-parsed-tramp-file-name newname v2 + (tramp-flush-file-properties + v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname) + (when (tramp-rclone-file-name-p newname) + (tramp-rclone-flush-directory-cache v2) + ;; The mount point's directory cache might need time + ;; to flush. + (while (not (file-exists-p newname)) + (tramp-flush-file-properties + v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname)))))))))) + +(defun tramp-rclone-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)) + (setq newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-rclone-do-copy-or-rename-file + 'copy filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + (tramp-run-real-handler + #'copy-file + (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 + (delete-directory (tramp-rclone-local-file-name directory) recursive trash) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) + (tramp-rclone-flush-directory-cache v))) + +(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 (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (tramp-rclone-flush-directory-cache v))) + +(defun tramp-rclone-handle-directory-files + (directory &optional full match nosort) + "Like `directory-files' for Tramp files." + (when (file-directory-p directory) + (setq directory (file-name-as-directory (expand-file-name directory))) + (with-parsed-tramp-file-name directory nil + (let ((result + (directory-files + (tramp-rclone-local-file-name directory) full match))) + ;; 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 + (unless (file-directory-p filename) + (setq filename (file-name-directory filename))) + (with-parsed-tramp-file-name (expand-file-name filename) nil + (tramp-message v 5 "file system info: %s" localname) + (tramp-rclone-send-command v "about" (concat host ":")) + (with-current-buffer (tramp-get-connection-buffer v) + (let (total used free) + (goto-char (point-min)) + (while (not (eobp)) + (when (looking-at "Total: [[:space:]]+\\([[:digit:]]+\\)") + (setq total (string-to-number (match-string 1)))) + (when (looking-at "Used: [[:space:]]+\\([[:digit:]]+\\)") + (setq used (string-to-number (match-string 1)))) + (when (looking-at "Free: [[:space:]]+\\([[:digit:]]+\\)") + (setq free (string-to-number (match-string 1)))) + (forward-line)) + (when used + ;; The used number of bytes is not part of the result. As + ;; side effect, we store it as file property. + (tramp-set-file-property v localname "used-bytes" used)) + ;; Result. + (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))) + (tramp-rclone-flush-directory-cache v))) + +(defun tramp-rclone-handle-rename-file + (filename newname &optional ok-if-already-exists) + "Like `rename-file' for Tramp files." + (setq filename (expand-file-name filename)) + (setq newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-rclone-do-copy-or-rename-file + '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)))) + + +;; 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 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-flush-directory-cache (vec) + "Flush directory cache of VEC mount." + (let ((rclone-pid + ;; Identify rclone process. + (when (tramp-get-connection-process vec) + (with-tramp-connection-property + (tramp-get-connection-process vec) "rclone-pid" + (catch 'pid + (dolist (pid (list-system-processes)) ;; "pidof rclone" ? + (and (string-match-p + (regexp-quote + (format "rclone mount %s:" (tramp-file-name-host vec))) + (or (cdr (assoc 'args (process-attributes pid))) "")) + (throw 'pid pid)))))))) + ;; Send a SIGHUP in order to flush directory cache. + (when rclone-pid + (tramp-message + vec 6 "Send SIGHUP %d: %s" + rclone-pid (cdr (assoc 'args (process-attributes rclone-pid)))) + (signal-process rclone-pid 'SIGHUP)))) + +(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))) + (if (tramp-rclone-file-name-p 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 "remote-file-name" + (tramp-rclone-maybe-open-connection v) + ;; 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))) + ;; It is a local file name. + filename)) + +(defun tramp-rclone-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." + (let ((host (tramp-file-name-host vec))) + (when (rassoc `(,host) (tramp-rclone-parse-device-names nil)) + (if (zerop (length host)) + (tramp-error vec 'file-error "Storage %s not connected" host)) + + ;; During completion, don't reopen a new connection. We check + ;; this for the process related to `tramp-buffer-name'; + ;; otherwise `start-file-process' wouldn't run ever when + ;; `non-essential' is non-nil. + (when (and (tramp-completion-mode-p) + (null (get-process (tramp-buffer-name 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-rclone-mount-point vec)) + (make-directory (tramp-rclone-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) + (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)))) + (while (not (file-exists-p (tramp-make-tramp-file-name vec 'localname))) + (tramp-cleanup-connection vec 'keep-debug 'keep-password)) + + ;; 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))) + +(defun tramp-rclone-send-command (vec &rest args) + "Send the COMMAND to connection VEC." + (with-current-buffer (tramp-get-connection-buffer vec) + (erase-buffer) + (let ((flags (tramp-get-method-parameter + vec (intern (format "tramp-%s-args" (car args)))))) + (apply #'tramp-call-process + vec tramp-rclone-program nil t nil (append args flags))))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-rclone 'force))) + +(provide 'tramp-rclone) + +;;; TODO: + +;; * If possible, get rid of "rclone mount". Maybe it is more +;; performant then. + +;;; tramp-rclone.el ends here diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 18ae2951084..6a82fef4f70 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -27,12 +27,9 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) (require 'tramp) -;; Pacify byte-compiler. -(eval-when-compile - (require 'dired)) - (declare-function dired-remove-file "dired-aux") (defvar dired-compress-file-suffixes) (defvar vc-handled-backends) @@ -41,14 +38,13 @@ (defvar vc-hg-program) ;;;###tramp-autoload -(defcustom tramp-inline-compress-start-size - (unless (memq system-type '(windows-nt)) 4096) +(defcustom tramp-inline-compress-start-size 4096 "The minimum size of compressing where inline transfer. -When inline transfer, compress transferred data of file -whose size is this value or above (up to `tramp-copy-size-limit'). +When inline transfer, compress transferred data of file whose +size is this value or above (up to `tramp-copy-size-limit' for +out-of-band methods). If it is nil, no compression at all will be applied." :group 'tramp - :version "26.3" :type '(choice (const nil) integer)) ;;;###tramp-autoload @@ -89,7 +85,6 @@ the default storage location, e.g. \"$HOME/.sh_history\"." (defconst tramp-display-escape-sequence-regexp "\e[[;0-9]+m" "Terminal control escape sequences for display attributes.") -;;;###tramp-autoload (defconst tramp-device-escape-sequence-regexp "\e[[0-9]+n" "Terminal control escape sequences for device status.") @@ -135,285 +130,264 @@ The string is used in `tramp-methods'.") ;; Initialize `tramp-methods' with the supported methods. ;;;###tramp-autoload -(add-to-list 'tramp-methods - '("rcp" - (tramp-login-program "rsh") - (tramp-login-args (("%h") ("-l" "%u"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-copy-program "rcp") - (tramp-copy-args (("-p" "%k") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("remcp" - (tramp-login-program "remsh") - (tramp-login-args (("%h") ("-l" "%u"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-copy-program "rcp") - (tramp-copy-args (("-p" "%k"))) - (tramp-copy-keep-date t))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("scp" - (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-shell "/bin/sh") - (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-keep-date t) - (tramp-copy-recursive t))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("scpx" - (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") - ("-e" "none") ("-t" "-t") ("%h") ("/bin/sh"))) - (tramp-async-args (("-q"))) - (tramp-remote-shell "/bin/sh") - (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-keep-date t) - (tramp-copy-recursive t))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("rsync" - (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-copy-program "rsync") - (tramp-copy-args (("-t" "%k") ("-p") ("-r") ("-s") ("-c"))) - (tramp-copy-env (("RSYNC_RSH") ("ssh" "%c"))) - (tramp-copy-keep-date t) - (tramp-copy-keep-tmpfile t) - (tramp-copy-recursive t))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("rsh" - (tramp-login-program "rsh") - (tramp-login-args (("%h") ("-l" "%u"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("remsh" - (tramp-login-program "remsh") - (tramp-login-args (("%h") ("-l" "%u"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("ssh" - (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("sshx" - (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") - ("-e" "none") ("-t" "-t") ("%h") ("/bin/sh"))) - (tramp-async-args (("-q"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("telnet" - (tramp-login-program "telnet") - (tramp-login-args (("%h") ("%p") ("2>/dev/null"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("nc" - (tramp-login-program "telnet") - (tramp-login-args (("%h") ("%p") ("2>/dev/null"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-copy-program "nc") - ;; We use "-v" for better error tracking. - (tramp-copy-args (("-w" "1") ("-v") ("%h") ("%r"))) - (tramp-remote-copy-program "nc") - ;; We use "-p" as required for newer busyboxes. For older - ;; busybox/nc versions, the value must be (("-l") ("%r")). This - ;; can be achieved by tweaking `tramp-connection-properties'. - (tramp-remote-copy-args (("-l") ("-p" "%r") ("2>/dev/null"))))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("su" - (tramp-login-program "su") - (tramp-login-args (("-") ("%u"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-connection-timeout 10))) -;;;###tramp-autoload -(add-to-list - 'tramp-methods - '("sg" - (tramp-login-program "sg") - (tramp-login-args (("-") ("%u"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-args ("-c")) - (tramp-connection-timeout 10))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("sudo" - (tramp-login-program "sudo") - ;; The password template must be masked. Otherwise, it could be - ;; interpreted as password prompt if the remote host echoes the command. - (tramp-login-args (("-u" "%u") ("-s") ("-H") - ("-p" "P\"\"a\"\"s\"\"s\"\"w\"\"o\"\"r\"\"d\"\":"))) - ;; Local $SHELL could be a nasty one, like zsh or fish. Let's override it. - (tramp-login-env (("SHELL") ("/bin/sh"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-connection-timeout 10))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("doas" - (tramp-login-program "doas") - (tramp-login-args (("-u" "%u") ("-s"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-args ("-c")) - (tramp-connection-timeout 10))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("ksu" - (tramp-login-program "ksu") - (tramp-login-args (("%u") ("-q"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-connection-timeout 10))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("krlogin" - (tramp-login-program "krlogin") - (tramp-login-args (("%h") ("-l" "%u") ("-x"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - `("plink" - (tramp-login-program "plink") - ;; ("%h") must be a single element, see `tramp-compute-multi-hops'. - (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t") - ("%h") ("\"") - (,(format - "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" - tramp-terminal-type - tramp-initial-end-of-output)) - ("/bin/sh") ("\""))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - `("plinkx" - (tramp-login-program "plink") - (tramp-login-args (("-load") ("%h") ("-t") ("\"") - (,(format - "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" - tramp-terminal-type - tramp-initial-end-of-output)) - ("/bin/sh") ("\""))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - `("pscp" - (tramp-login-program "plink") - (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t") - ("%h") ("\"") - (,(format - "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" - tramp-terminal-type - tramp-initial-end-of-output)) - ("/bin/sh") ("\""))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-copy-program "pscp") - (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-scp") ("-p" "%k") - ("-q") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - `("psftp" - (tramp-login-program "plink") - (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t") - ("%h") ("\"") - (,(format - "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" - tramp-terminal-type - tramp-initial-end-of-output)) - ("/bin/sh") ("\""))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-c")) - (tramp-copy-program "pscp") - (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-sftp") ("-p" "%k") - ("-q"))) - (tramp-copy-keep-date t))) -;;;###tramp-autoload -(add-to-list 'tramp-methods - '("fcp" - (tramp-login-program "fsh") - (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-login ("-l")) - (tramp-remote-shell-args ("-i") ("-c")) - (tramp-copy-program "fcp") - (tramp-copy-args (("-p" "%k"))) - (tramp-copy-keep-date t))) - -;;;###tramp-autoload -(add-to-list 'tramp-default-method-alist - `(,tramp-local-host-regexp "\\`root\\'" "su")) - -;;;###tramp-autoload -(add-to-list 'tramp-default-user-alist - `(,(concat "\\`" (regexp-opt '("su" "sudo" "doas" "ksu")) "\\'") - nil "root")) -;; Do not add "ssh" based methods, otherwise ~/.ssh/config would be ignored. -;; Do not add "plink" based methods, they ask interactively for the user. -;;;###tramp-autoload -(add-to-list 'tramp-default-user-alist - `(,(concat - "\\`" - (regexp-opt - '("rcp" "remcp" "rsh" "telnet" "nc" "krlogin" "fcp")) - "\\'") - nil ,(user-login-name))) +(tramp--with-startup + (add-to-list 'tramp-methods + '("rcp" + (tramp-login-program "rsh") + (tramp-login-args (("%h") ("-l" "%u"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-copy-program "rcp") + (tramp-copy-args (("-p" "%k") ("-r"))) + (tramp-copy-keep-date t) + (tramp-copy-recursive t))) + (add-to-list 'tramp-methods + '("remcp" + (tramp-login-program "remsh") + (tramp-login-args (("%h") ("-l" "%u"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-copy-program "rcp") + (tramp-copy-args (("-p" "%k"))) + (tramp-copy-keep-date t))) + (add-to-list 'tramp-methods + '("scp" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") + ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-shell "/bin/sh") + (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-keep-date t) + (tramp-copy-recursive t))) + (add-to-list 'tramp-methods + '("scpx" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") + ("-e" "none") ("-t" "-t") ("%h") ("/bin/sh"))) + (tramp-async-args (("-q"))) + (tramp-remote-shell "/bin/sh") + (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-keep-date t) + (tramp-copy-recursive t))) + (add-to-list 'tramp-methods + '("rsync" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") + ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-copy-program "rsync") + (tramp-copy-args (("-t" "%k") ("-p") ("-r") ("-s") ("-c"))) + (tramp-copy-env (("RSYNC_RSH") ("ssh" "%c"))) + (tramp-copy-keep-date t) + (tramp-copy-keep-tmpfile t) + (tramp-copy-recursive t))) + (add-to-list 'tramp-methods + '("rsh" + (tramp-login-program "rsh") + (tramp-login-args (("%h") ("-l" "%u"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + (add-to-list 'tramp-methods + '("remsh" + (tramp-login-program "remsh") + (tramp-login-args (("%h") ("-l" "%u"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + (add-to-list 'tramp-methods + '("ssh" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") + ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + (add-to-list 'tramp-methods + '("sshx" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") + ("-e" "none") ("-t" "-t") ("%h") ("/bin/sh"))) + (tramp-async-args (("-q"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + (add-to-list 'tramp-methods + '("telnet" + (tramp-login-program "telnet") + (tramp-login-args (("%h") ("%p") ("2>/dev/null"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + (add-to-list 'tramp-methods + '("nc" + (tramp-login-program "telnet") + (tramp-login-args (("%h") ("%p") ("2>/dev/null"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-copy-program "nc") + ;; We use "-v" for better error tracking. + (tramp-copy-args (("-w" "1") ("-v") ("%h") ("%r"))) + (tramp-remote-copy-program "nc") + ;; We use "-p" as required for newer busyboxes. For older + ;; busybox/nc versions, the value must be (("-l") ("%r")). This + ;; can be achieved by tweaking `tramp-connection-properties'. + (tramp-remote-copy-args (("-l") ("-p" "%r") ("2>/dev/null"))))) + (add-to-list 'tramp-methods + '("su" + (tramp-login-program "su") + (tramp-login-args (("-") ("%u"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10))) + (add-to-list 'tramp-methods + '("sg" + (tramp-login-program "sg") + (tramp-login-args (("-") ("%u"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10))) + (add-to-list 'tramp-methods + '("sudo" + (tramp-login-program "sudo") + ;; The password template must be masked. Otherwise, + ;; it could be interpreted as password prompt if the + ;; remote host echoes the command. + (tramp-login-args (("-u" "%u") ("-s") ("-H") + ("-p" "P\"\"a\"\"s\"\"s\"\"w\"\"o\"\"r\"\"d\"\":"))) + ;; Local $SHELL could be a nasty one, like zsh or + ;; fish. Let's override it. + (tramp-login-env (("SHELL") ("/bin/sh"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10) + (tramp-session-timeout 300))) + (add-to-list 'tramp-methods + '("doas" + (tramp-login-program "doas") + (tramp-login-args (("-u" "%u") ("-s"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10) + (tramp-session-timeout 300))) + (add-to-list 'tramp-methods + '("ksu" + (tramp-login-program "ksu") + (tramp-login-args (("%u") ("-q"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10))) + (add-to-list 'tramp-methods + '("krlogin" + (tramp-login-program "krlogin") + (tramp-login-args (("%h") ("-l" "%u") ("-x"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + (add-to-list 'tramp-methods + `("plink" + (tramp-login-program "plink") + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t") + ("%h") ("\"") + (,(format + "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" + tramp-terminal-type + tramp-initial-end-of-output)) + ("/bin/sh") ("\""))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + (add-to-list 'tramp-methods + `("plinkx" + (tramp-login-program "plink") + (tramp-login-args (("-load") ("%h") ("-t") ("\"") + (,(format + "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" + tramp-terminal-type + tramp-initial-end-of-output)) + ("/bin/sh") ("\""))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + (add-to-list 'tramp-methods + `("pscp" + (tramp-login-program "plink") + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t") + ("%h") ("\"") + (,(format + "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" + tramp-terminal-type + tramp-initial-end-of-output)) + ("/bin/sh") ("\""))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-copy-program "pscp") + (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-scp") ("-p" "%k") + ("-q") ("-r"))) + (tramp-copy-keep-date t) + (tramp-copy-recursive t))) + (add-to-list 'tramp-methods + `("psftp" + (tramp-login-program "plink") + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t") + ("%h") ("\"") + (,(format + "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" + tramp-terminal-type + tramp-initial-end-of-output)) + ("/bin/sh") ("\""))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-copy-program "pscp") + (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-sftp") ("-p" "%k") + ("-q"))) + (tramp-copy-keep-date t))) + (add-to-list 'tramp-methods + '("fcp" + (tramp-login-program "fsh") + (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-i") ("-c")) + (tramp-copy-program "fcp") + (tramp-copy-args (("-p" "%k"))) + (tramp-copy-keep-date t))) + + (add-to-list 'tramp-default-method-alist + `(,tramp-local-host-regexp "\\`root\\'" "su")) + + (add-to-list 'tramp-default-user-alist + `(,(concat "\\`" (regexp-opt '("su" "sudo" "doas" "ksu")) "\\'") + nil "root")) + ;; Do not add "ssh" based methods, otherwise ~/.ssh/config would be ignored. + ;; Do not add "plink" based methods, they ask interactively for the user. + (add-to-list 'tramp-default-user-alist + `(,(concat + "\\`" + (regexp-opt + '("rcp" "remcp" "rsh" "telnet" "nc" "krlogin" "fcp")) + "\\'") + nil ,(user-login-name)))) ;;;###tramp-autoload (defconst tramp-completion-function-alist-rsh @@ -461,33 +435,32 @@ The string is used in `tramp-methods'.") "Default list of (FUNCTION REGISTRY) pairs to be examined for putty sessions.") ;;;###tramp-autoload -(eval-after-load 'tramp - '(progn - (tramp-set-completion-function "rcp" tramp-completion-function-alist-rsh) - (tramp-set-completion-function "remcp" tramp-completion-function-alist-rsh) - (tramp-set-completion-function "scp" tramp-completion-function-alist-ssh) - (tramp-set-completion-function "scpx" tramp-completion-function-alist-ssh) - (tramp-set-completion-function "rsync" tramp-completion-function-alist-ssh) - (tramp-set-completion-function "rsh" tramp-completion-function-alist-rsh) - (tramp-set-completion-function "remsh" tramp-completion-function-alist-rsh) - (tramp-set-completion-function "ssh" tramp-completion-function-alist-ssh) - (tramp-set-completion-function "sshx" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "telnet" tramp-completion-function-alist-telnet) - (tramp-set-completion-function "nc" tramp-completion-function-alist-telnet) - (tramp-set-completion-function "su" tramp-completion-function-alist-su) - (tramp-set-completion-function "sudo" tramp-completion-function-alist-su) - (tramp-set-completion-function "doas" tramp-completion-function-alist-su) - (tramp-set-completion-function "ksu" tramp-completion-function-alist-su) - (tramp-set-completion-function "sg" tramp-completion-function-alist-sg) - (tramp-set-completion-function - "krlogin" tramp-completion-function-alist-rsh) - (tramp-set-completion-function "plink" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "plinkx" tramp-completion-function-alist-putty) - (tramp-set-completion-function "pscp" tramp-completion-function-alist-ssh) - (tramp-set-completion-function "psftp" tramp-completion-function-alist-ssh) - (tramp-set-completion-function "fcp" tramp-completion-function-alist-ssh))) +(tramp--with-startup + (tramp-set-completion-function "rcp" tramp-completion-function-alist-rsh) + (tramp-set-completion-function "remcp" tramp-completion-function-alist-rsh) + (tramp-set-completion-function "scp" tramp-completion-function-alist-ssh) + (tramp-set-completion-function "scpx" tramp-completion-function-alist-ssh) + (tramp-set-completion-function "rsync" tramp-completion-function-alist-ssh) + (tramp-set-completion-function "rsh" tramp-completion-function-alist-rsh) + (tramp-set-completion-function "remsh" tramp-completion-function-alist-rsh) + (tramp-set-completion-function "ssh" tramp-completion-function-alist-ssh) + (tramp-set-completion-function "sshx" tramp-completion-function-alist-ssh) + (tramp-set-completion-function + "telnet" tramp-completion-function-alist-telnet) + (tramp-set-completion-function "nc" tramp-completion-function-alist-telnet) + (tramp-set-completion-function "su" tramp-completion-function-alist-su) + (tramp-set-completion-function "sudo" tramp-completion-function-alist-su) + (tramp-set-completion-function "doas" tramp-completion-function-alist-su) + (tramp-set-completion-function "ksu" tramp-completion-function-alist-su) + (tramp-set-completion-function "sg" tramp-completion-function-alist-sg) + (tramp-set-completion-function + "krlogin" tramp-completion-function-alist-rsh) + (tramp-set-completion-function "plink" tramp-completion-function-alist-ssh) + (tramp-set-completion-function + "plinkx" tramp-completion-function-alist-putty) + (tramp-set-completion-function "pscp" tramp-completion-function-alist-ssh) + (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 @@ -696,7 +669,7 @@ else $uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; printf( - \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) -1)\\n\", + \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u %%u t %%u -1)\\n\", $type, $stat[3], $uid, @@ -709,8 +682,7 @@ printf( $stat[10] & 0xffff, $stat[7], $stat[2], - $stat[1] >> 16 & 0xffff, - $stat[1] & 0xffff + $stat[1] );' \"$1\" \"$2\" 2>/dev/null" "Perl script to produce output suitable for use with `file-attributes' on the remote file system. @@ -947,24 +919,19 @@ od -v -t x1 -A n </dev/null && \ busybox awk '{}' </dev/null" "Test command for checking `tramp-awk-encode' and `tramp-awk-decode'.") -(defconst tramp-stat-marker "/////" - "Marker in stat commands for file attributes.") - -(defconst tramp-stat-quoted-marker "\\/\\/\\/\\/\\/" - "Quoted marker in stat commands for file attributes.") - (defconst tramp-vc-registered-read-file-names "echo \"(\" while read file; do + quoted=`echo \"$file\" | sed -e \"s/\\\"/\\\\\\\\\\\\\\\\\\\"/\"` if %s \"$file\"; then - echo \"(\\\"$file\\\" \\\"file-exists-p\\\" t)\" + echo \"(\\\"$quoted\\\" \\\"file-exists-p\\\" t)\" else - echo \"(\\\"$file\\\" \\\"file-exists-p\\\" nil)\" + echo \"(\\\"$quoted\\\" \\\"file-exists-p\\\" nil)\" fi if %s \"$file\"; then - echo \"(\\\"$file\\\" \\\"file-readable-p\\\" t)\" + echo \"(\\\"$quoted\\\" \\\"file-readable-p\\\" t)\" else - echo \"(\\\"$file\\\" \\\"file-readable-p\\\" nil)\" + echo \"(\\\"$quoted\\\" \\\"file-readable-p\\\" nil)\" fi done echo \")\"" @@ -977,7 +944,7 @@ of command line.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-sh-file-name-handler-alist - '(;; `access-file' performed by default handler. + '((access-file . tramp-handle-access-file) (add-name-to-file . tramp-sh-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-sh-handle-copy-directory) @@ -991,6 +958,7 @@ of command line.") . tramp-sh-handle-directory-files-and-attributes) (dired-compress-file . tramp-sh-handle-dired-compress-file) (dired-uncache . tramp-handle-dired-uncache) + (exec-path . tramp-sh-handle-exec-path) (expand-file-name . tramp-sh-handle-expand-file-name) (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . tramp-sh-handle-file-acl) @@ -1023,7 +991,6 @@ of command line.") (file-truename . tramp-sh-handle-file-truename) (file-writable-p . tramp-sh-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) - ;; `find-file-noselect' performed by default handler. ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-sh-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) @@ -1032,6 +999,7 @@ of command line.") (make-directory . tramp-sh-handle-make-directory) ;; `make-directory-internal' performed by default handler. (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-process . tramp-sh-handle-make-process) (make-symbolic-link . tramp-sh-handle-make-symbolic-link) (process-file . tramp-sh-handle-process-file) (rename-file . tramp-sh-handle-rename-file) @@ -1041,9 +1009,10 @@ of command line.") (set-file-times . tramp-sh-handle-set-file-times) (set-visited-file-modtime . tramp-sh-handle-set-visited-file-modtime) (shell-command . tramp-handle-shell-command) - (start-file-process . tramp-sh-handle-start-file-process) + (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-set-file-uid-gid . tramp-sh-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) (vc-registered . tramp-sh-handle-vc-registered) (verify-visited-file-modtime . tramp-sh-handle-verify-visited-file-modtime) @@ -1061,15 +1030,17 @@ of the symlink. If TARGET is a Tramp file, only the localname component is used as the target of the symlink." (if (not (tramp-tramp-file-p (expand-file-name linkname))) (tramp-run-real-handler - 'make-symbolic-link (list target linkname ok-if-already-exists)) + #'make-symbolic-link (list target linkname ok-if-already-exists)) (with-parsed-tramp-file-name linkname nil ;; If TARGET is a Tramp name, use just the localname component. - (when (and (tramp-tramp-file-p target) - (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target))))) + ;; Don't check for a proper method. + (let ((non-essential t)) + (when (and (tramp-tramp-file-p target) + (tramp-file-name-equal-p v (tramp-dissect-file-name target))) + (setq target + (tramp-file-name-localname + (tramp-dissect-file-name (expand-file-name target)))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -1079,7 +1050,7 @@ component is used as the target of the symlink." (let ((ln (tramp-get-remote-ln v)) (cwd (tramp-run-real-handler - 'file-name-directory (list localname)))) + #'file-name-directory (list localname)))) (unless ln (tramp-error v 'file-error @@ -1098,8 +1069,8 @@ component is used as the target of the symlink." (tramp-error v 'file-already-exists localname) (delete-file linkname))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) ;; Right, they are on the same host, regardless of user, ;; method, etc. We now make the link on the remote @@ -1123,10 +1094,10 @@ component is used as the target of the symlink." ;; Preserve trailing "/". (funcall (if (string-equal (file-name-nondirectory filename) "") - 'file-name-as-directory 'identity) + #'file-name-as-directory #'identity) (with-parsed-tramp-file-name (expand-file-name filename) nil (tramp-make-tramp-file-name - method user domain host port + v (with-tramp-file-property v localname "file-truename" (let ((result nil) ; result steps in reverse order (quoted (tramp-compat-file-name-quoted-p localname)) @@ -1171,19 +1142,16 @@ component is used as the target of the symlink." (setq thisstep (pop steps)) (tramp-message v 5 "Check %s" - (mapconcat 'identity - (append '("") (reverse result) (list thisstep)) - "/")) + (string-join + (append '("") (reverse result) (list thisstep)) "/")) (setq symlink-target (tramp-compat-file-attribute-type (file-attributes (tramp-make-tramp-file-name - method user domain host port - (mapconcat 'identity - (append '("") - (reverse result) - (list thisstep)) - "/"))))) + v + (string-join + (append '("") (reverse result) (list thisstep)) "/") + 'nohop)))) (cond ((string= "." thisstep) (tramp-message v 5 "Ignoring step `.'")) ((string= ".." thisstep) @@ -1208,12 +1176,8 @@ component is used as the target of the symlink." "Maximum number (%d) of symlinks exceeded" numchase-limit)) (setq result (reverse result)) ;; Combine list to form string. - (setq result - (if result - (mapconcat 'identity (cons "" result) "/") - "/")) - (when (string= "" result) - (setq result "/"))))) + (setq result (if result (string-join (cons "" result) "/") "/")) + (when (string-empty-p result) (setq result "/"))))) ;; Detect cycle. (when (and (file-symlink-p filename) @@ -1227,7 +1191,8 @@ component is used as the target of the symlink." (let (file-name-handler-alist) (setq result (tramp-compat-file-name-quote result)))) (tramp-message v 4 "True name of `%s' is `%s'" localname result) - result)))))) + result)) + 'nohop)))) ;; Basic functions. @@ -1255,18 +1220,24 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname (format "file-attributes-%s" id-format) - (save-excursion - (tramp-convert-file-attributes - v - (or - (cond - ((tramp-get-remote-stat v) - (tramp-do-file-attributes-with-stat v localname id-format)) - ((tramp-get-remote-perl v) - (tramp-do-file-attributes-with-perl v localname id-format)) - (t nil)) - ;; The scripts could fail, for example with huge file size. - (tramp-do-file-attributes-with-ls v localname id-format))))))))) + (tramp-convert-file-attributes + v + (or + (cond + ((tramp-get-remote-stat v) + (tramp-do-file-attributes-with-stat v localname id-format)) + ((tramp-get-remote-perl v) + (tramp-do-file-attributes-with-perl v localname id-format)) + (t nil)) + ;; The scripts could fail, for example with huge file size. + (tramp-do-file-attributes-with-ls v localname id-format)))))))) + +(defun tramp-sh--quoting-style-options (vec) + (or + (tramp-get-ls-command-with + vec "--quoting-style=literal --show-control-chars") + (tramp-get-ls-command-with vec "-w") + "")) (defun tramp-do-file-attributes-with-ls (vec localname &optional id-format) "Implement `file-attributes' for Tramp files using the ls(1) command." @@ -1293,12 +1264,7 @@ component is used as the target of the symlink." (if (eq id-format 'integer) "-ildn" "-ild") ;; On systems which have no quoting style, file names ;; with special characters could fail. - (cond - ((tramp-get-ls-command-with-quoting-style vec) - "--quoting-style=c") - ((tramp-get-ls-command-with-w-option vec) - "-w") - (t "")) + (tramp-sh--quoting-style-options vec) (tramp-shell-quote-argument localname))) ;; Parse `ls -l' output ... (with-current-buffer (tramp-get-buffer vec) @@ -1331,7 +1297,7 @@ component is used as the target of the symlink." (when symlinkp (search-forward "-> ") (setq res-symlink-target - (if (tramp-get-ls-command-with-quoting-style vec) + (if (looking-at-p "\"") (read (current-buffer)) (buffer-substring (point) (point-at-eol))))) ;; Return data gathered. @@ -1345,13 +1311,10 @@ component is used as the target of the symlink." res-uid ;; 3. File gid. res-gid - ;; 4. Last access time, as a list of integers. Normally - ;; this would be in the same format as `current-time', but - ;; the subseconds part is not currently implemented, and - ;; (0 0) denotes an unknown time. - ;; 5. Last modification time, likewise. - ;; 6. Last status change time, likewise. - '(0 0) '(0 0) '(0 0) ;CCC how to find out? + ;; 4. Last access time. + ;; 5. Last modification time. + ;; 6. Last status change time. + tramp-time-dont-know tramp-time-dont-know tramp-time-dont-know ;; 7. Size in bytes (-1, if number is out of range). res-size ;; 8. File modes, as a string of ten letters or dashes as in ls -l. @@ -1382,15 +1345,16 @@ component is used as the target of the symlink." (tramp-send-command-and-read vec (format - (concat - ;; On Opsware, pdksh (which is the true name of ksh there) - ;; doesn't parse correctly the sequence "((". Therefore, we add - ;; a space. Apostrophes in the stat output are masked as - ;; `tramp-stat-marker', in order to make a proper shell escape of - ;; them in file names. - "( (%s %s || %s -h %s) && (%s -c " - "'((%s%%N%s) %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 %s%%A%s t %%ie0 -1)' " - "%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g') || echo nil)") + (eval-when-compile + (concat + ;; On Opsware, pdksh (which is the true name of ksh there) + ;; doesn't parse correctly the sequence "((". Therefore, we + ;; add a space. Apostrophes in the stat output are masked as + ;; `tramp-stat-marker', in order to make a proper shell escape + ;; of them in file names. + "( (%s %s || %s -h %s) && (%s -c " + "'((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " + "%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g') || echo nil)")) (tramp-get-file-exists-command vec) (tramp-shell-quote-argument localname) (tramp-get-test-command vec) @@ -1398,9 +1362,11 @@ component is used as the target of the symlink." (tramp-get-remote-stat vec) tramp-stat-marker tramp-stat-marker (if (eq id-format 'integer) - "%ue0" (concat tramp-stat-marker "%U" tramp-stat-marker)) + "%u" + (eval-when-compile (concat tramp-stat-marker "%U" tramp-stat-marker))) (if (eq id-format 'integer) - "%ge0" (concat tramp-stat-marker "%G" tramp-stat-marker)) + "%g" + (eval-when-compile (concat tramp-stat-marker "%G" tramp-stat-marker))) tramp-stat-marker tramp-stat-marker (tramp-shell-quote-argument localname) tramp-stat-quoted-marker))) @@ -1411,20 +1377,17 @@ component is used as the target of the symlink." (error "Can't set-visited-file-modtime: buffer `%s' not visiting a file" (buffer-name))) (if time-list - (tramp-run-real-handler 'set-visited-file-modtime (list time-list)) + (tramp-run-real-handler #'set-visited-file-modtime (list time-list)) (let ((f (buffer-file-name)) coding-system-used) (with-parsed-tramp-file-name f nil (let* ((remote-file-name-inhibit-cache t) (attr (file-attributes f)) - ;; '(-1 65535) means file doesn't exists yet. (modtime (or (tramp-compat-file-attribute-modification-time attr) - '(-1 65535)))) + tramp-time-doesnt-exist))) (setq coding-system-used last-coding-system-used) - ;; We use '(0 0) as a don't-know value. See also - ;; `tramp-do-file-attributes-with-ls'. - (if (not (equal modtime '(0 0))) - (tramp-run-real-handler 'set-visited-file-modtime (list modtime)) + (if (not (tramp-compat-time-equal-p modtime tramp-time-dont-know)) + (tramp-run-real-handler #'set-visited-file-modtime (list modtime)) (progn (tramp-send-command v @@ -1452,7 +1415,7 @@ of." ;; recorded last modification time, or there is no established ;; connection. (if (or (not f) - (eq (visited-file-modtime) 0) + (zerop (float-time (visited-file-modtime))) (not (file-remote-p f nil 'connected))) t (with-parsed-tramp-file-name f nil @@ -1463,16 +1426,10 @@ of." (cond ;; File exists, and has a known modtime. - ((and attr (not (equal modtime '(0 0)))) - (< (abs (tramp-time-diff - modtime - ;; For compatibility, deal with both the old - ;; (HIGH . LOW) and the new (HIGH LOW) return - ;; values of `visited-file-modtime'. - (if (atom (cdr mt)) - (list (car mt) (cdr mt)) - mt))) - 2)) + ((and attr + (not + (tramp-compat-time-equal-p modtime tramp-time-dont-know))) + (< (abs (tramp-time-diff modtime mt)) 2)) ;; Modtime has the don't know value. (attr (tramp-send-command @@ -1488,13 +1445,13 @@ of." v localname "visited-file-modtime-ild" ""))) ;; If file does not exist, say it is not modified if and ;; only if that agrees with the buffer's record. - (t (equal mt '(-1 65535)))))))))) + (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist))))))))) (defun tramp-sh-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) ;; FIXME: extract the proper text from chmod's stderr. (tramp-barf-unless-okay v @@ -1505,11 +1462,14 @@ of." "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (when (tramp-get-remote-touch v) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) - (let ((time (if (or (null time) (equal time '(0 0))) - (current-time) - time))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (let ((time + (if (or (null time) + (tramp-compat-time-equal-p time tramp-time-doesnt-exist) + (tramp-compat-time-equal-p time tramp-time-dont-know)) + (current-time) + time))) (tramp-send-command-and-check v (format "env TZ=UTC %s %s %s" @@ -1519,39 +1479,26 @@ of." "") (tramp-shell-quote-argument localname))))))) -(defun tramp-set-file-uid-gid (filename &optional uid gid) - "Set the ownership for FILENAME. -If UID and GID are provided, these values are used; otherwise uid -and gid of the corresponding user is taken. Both parameters must -be non-negative integers." +(defun tramp-sh-handle-set-file-uid-gid (filename &optional uid gid) + "Like `tramp-set-file-uid-gid' for Tramp files." ;; Modern Unices allow chown only for root. So we might need ;; another implementation, see `dired-do-chown'. OTOH, it is mostly ;; working with su(do)? when it is needed, so it shall succeed in ;; the majority of cases. ;; Don't modify `last-coding-system-used' by accident. (let ((last-coding-system-used last-coding-system-used)) - (if (tramp-tramp-file-p filename) - (with-parsed-tramp-file-name filename nil - (if (and (zerop (user-uid)) (tramp-local-host-p v)) - ;; If we are root on the local host, we can do it directly. - (tramp-set-file-uid-gid localname uid gid) - (let ((uid (or (and (natnump uid) uid) - (tramp-get-remote-uid v 'integer))) - (gid (or (and (natnump gid) gid) - (tramp-get-remote-gid v 'integer)))) - (tramp-send-command - v (format - "chown %d:%d %s" uid gid - (tramp-shell-quote-argument localname)))))) - - ;; We handle also the local part, because there doesn't exist - ;; `set-file-uid-gid'. On W32 "chown" does not work. - (unless (memq system-type '(ms-dos windows-nt)) - (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer))) - (gid (or (and (natnump gid) gid) (tramp-get-local-gid 'integer)))) - (tramp-call-process - nil "chown" nil nil nil - (format "%d:%d" uid gid) (shell-quote-argument filename))))))) + (with-parsed-tramp-file-name filename nil + (if (and (zerop (user-uid)) (tramp-local-host-p v)) + ;; If we are root on the local host, we can do it directly. + (tramp-set-file-uid-gid localname uid gid) + (let ((uid (or (and (natnump uid) uid) + (tramp-get-remote-uid v 'integer))) + (gid (or (and (natnump gid) gid) + (tramp-get-remote-gid v 'integer)))) + (tramp-send-command + v (format + "chown %d:%d %s" uid gid + (tramp-shell-quote-argument localname)))))))) (defun tramp-remote-selinux-p (vec) "Check, whether SELINUX is enabled on the remote host." @@ -1563,8 +1510,9 @@ be non-negative integers." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-selinux-context" (let ((context '(nil nil nil nil)) - (regexp (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):" - "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)"))) + (regexp (eval-when-compile + (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):" + "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)")))) (when (and (tramp-remote-selinux-p v) (tramp-send-command-and-check v (format @@ -1598,8 +1546,7 @@ be non-negative integers." (if (and user role type range) (tramp-set-file-property v localname "file-selinux-context" context) - (tramp-set-file-property - v localname "file-selinux-context" 'undef)) + (tramp-flush-file-property v localname "file-selinux-context")) t))))) (defun tramp-remote-acl-p (vec) @@ -1639,7 +1586,7 @@ be non-negative integers." (tramp-set-file-property v localname "file-acl" acl-string) t) ;; In case of errors, we return nil. - (tramp-set-file-property v localname "file-acl-string" 'undef) + (tramp-flush-file-property v localname "file-acl-string") nil))) ;; Simple functions using the `test' command. @@ -1669,28 +1616,26 @@ be non-negative integers." ;; 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) - ;; We are sure both files exist at this point. - (t - (save-excursion - ;; 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. + (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 - (equal (tramp-compat-file-attribute-modification-time fa1) - '(0 0))) + (tramp-compat-time-equal-p + (tramp-compat-file-attribute-modification-time fa1) + tramp-time-dont-know)) (not - (equal (tramp-compat-file-attribute-modification-time fa2) - '(0 0)))) - (> 0 (tramp-time-diff - (tramp-compat-file-attribute-modification-time fa2) - (tramp-compat-file-attribute-modification-time fa1))) + (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 @@ -1705,7 +1650,7 @@ be non-negative integers." file1 file2))) (with-parsed-tramp-file-name file1 nil (tramp-run-test2 - (tramp-get-test-nt-command v) file1 file2)))))))) + (tramp-get-test-nt-command v) file1 file2))))))) ;; Functions implemented using the basic functions above. @@ -1762,25 +1707,22 @@ be non-negative integers." (with-tramp-file-property v localname (format "directory-files-and-attributes-%s" id-format) - (save-excursion - (mapcar - (lambda (x) - (cons (car x) - (tramp-convert-file-attributes v (cdr x)))) - (or - (cond - ((tramp-get-remote-stat v) - (tramp-do-directory-files-and-attributes-with-stat - v localname id-format)) - ((tramp-get-remote-perl v) - (tramp-do-directory-files-and-attributes-with-perl - v localname id-format)) - (t nil))))))))) + (mapcar + (lambda (x) + (cons (car x) (tramp-convert-file-attributes v (cdr x)))) + (cond + ((tramp-get-remote-stat v) + (tramp-do-directory-files-and-attributes-with-stat + v localname id-format)) + ((tramp-get-remote-perl v) + (tramp-do-directory-files-and-attributes-with-perl + v localname id-format)) + (t nil))))))) result item) (while temp (setq item (pop temp)) - (when (or (null match) (string-match match (car item))) + (when (or (null match) (string-match-p match (car item))) (when full (setcar item (expand-file-name (car item) directory))) (push item result))) @@ -1814,33 +1756,32 @@ be non-negative integers." (tramp-send-command-and-read vec (format - (concat - ;; We must care about file names with spaces, or starting with - ;; "-"; this would confuse xargs. "ls -aQ" might be a solution, - ;; but it does not work on all remote systems. Apostrophes in - ;; the stat output are masked as `tramp-stat-marker', in order to - ;; make a proper shell escape of them in file names. - "cd %s && echo \"(\"; (%s %s -a | " - "xargs %s -c " - "'(%s%%n%s (%s%%N%s) %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 %s%%A%s t %%ie0 -1)' " - "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"") + (eval-when-compile + (concat + ;; We must care about file names with spaces, or starting with + ;; "-"; this would confuse xargs. "ls -aQ" might be a + ;; solution, but it does not work on all remote systems. + ;; Apostrophes in the stat output are masked as + ;; `tramp-stat-marker', in order to make a proper shell escape + ;; of them in file names. + "cd %s && echo \"(\"; (%s %s -a | " + "xargs %s -c " + "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " + "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"")) (tramp-shell-quote-argument localname) (tramp-get-ls-command vec) ;; On systems which have no quoting style, file names with special ;; characters could fail. - (cond - ((tramp-get-ls-command-with-quoting-style vec) - "--quoting-style=shell") - ((tramp-get-ls-command-with-w-option vec) - "-w") - (t "")) + (tramp-sh--quoting-style-options vec) (tramp-get-remote-stat vec) tramp-stat-marker tramp-stat-marker tramp-stat-marker tramp-stat-marker (if (eq id-format 'integer) - "%ue0" (concat tramp-stat-marker "%U" tramp-stat-marker)) + "%u" + (eval-when-compile (concat tramp-stat-marker "%U" tramp-stat-marker))) (if (eq id-format 'integer) - "%ge0" (concat tramp-stat-marker "%G" tramp-stat-marker)) + "%g" + (eval-when-compile (concat tramp-stat-marker "%G" tramp-stat-marker))) tramp-stat-marker tramp-stat-marker tramp-stat-quoted-marker))) @@ -1848,7 +1789,7 @@ be non-negative integers." ;; files. (defun tramp-sh-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (unless (save-match-data (string-match "/" filename)) + (unless (string-match-p "/" filename) (all-completions filename (with-parsed-tramp-file-name (expand-file-name directory) nil @@ -1867,12 +1808,13 @@ be non-negative integers." (format "tramp_perl_file_name_all_completions %s" (tramp-shell-quote-argument localname))) - (format (concat - "(cd %s 2>&1 && %s -a 2>/dev/null" - " | while IFS= read f; do" - " if %s -d \"$f\" 2>/dev/null;" - " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done" - " && \\echo ok) || \\echo fail") + (format (eval-when-compile + (concat + "(cd %s 2>&1 && %s -a 2>/dev/null" + " | while IFS= read f; do" + " if %s -d \"$f\" 2>/dev/null;" + " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done" + " && \\echo ok) || \\echo fail")) (tramp-shell-quote-argument localname) (tramp-get-ls-command v) (tramp-get-test-command v)))) @@ -1883,7 +1825,7 @@ be non-negative integers." ;; Check result code, found in last line of output. (forward-line -1) - (if (looking-at "^fail$") + (if (looking-at-p "^fail$") (progn ;; Grab error message from line before last line ;; (it was put there by `cd 2>&1'). @@ -1896,7 +1838,7 @@ be non-negative integers." ;; then it should end in `ok'. If neither are in the ;; buffer something went seriously wrong on the remote ;; side. - (unless (looking-at "^ok$") + (unless (looking-at-p "^ok$") (tramp-error v 'file-error "\ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" @@ -1933,8 +1875,8 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" v2-localname))))) (tramp-error v2 'file-already-exists newname) (delete-file newname))) - (tramp-flush-file-property v2 (file-name-directory v2-localname)) - (tramp-flush-file-property v2 v2-localname) + (tramp-flush-file-properties v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname) (tramp-barf-unless-okay v1 (format "%s %s %s" ln @@ -1987,7 +1929,7 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" (setq newname (expand-file-name (file-name-nondirectory dirname) newname))) - (when (not (file-directory-p (file-name-directory newname))) + (unless (file-directory-p (file-name-directory newname)) (make-directory (file-name-directory newname) parents)) (tramp-do-copy-or-rename-file-out-of-band 'copy dirname newname keep-date)) @@ -2000,8 +1942,8 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" ;; When newname did exist, we have wrong cached values. (when t2 (with-parsed-tramp-file-name newname nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)))))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname)))))) (defun tramp-sh-handle-rename-file (filename newname &optional ok-if-already-exists) @@ -2017,7 +1959,7 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" 'rename filename newname ok-if-already-exists 'keep-time '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-do-copy-or-rename-file (op filename newname &optional ok-if-already-exists keep-date @@ -2051,11 +1993,13 @@ file names." (length (tramp-compat-file-attribute-size (file-attributes (file-truename filename)))) (attributes (and preserve-extended-attributes - (apply 'file-extended-attributes (list filename))))) + (apply #'file-extended-attributes (list filename))))) (with-parsed-tramp-file-name (if t1 filename newname) nil (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter v 0 (format "%s %s to %s" @@ -2123,19 +2067,21 @@ file names." ;; errors, because ACL strings could be incompatible. (when attributes (ignore-errors - (apply 'set-file-extended-attributes (list newname attributes)))) + (apply #'set-file-extended-attributes (list newname attributes)))) ;; In case of `rename', we must flush the cache of the source file. (when (and t1 (eq op 'rename)) (with-parsed-tramp-file-name filename v1 - (tramp-flush-file-property v1 (file-name-directory v1-localname)) - (tramp-flush-file-property v1 v1-localname))) + (tramp-flush-file-properties + v1 (file-name-directory v1-localname)) + (tramp-flush-file-properties v1 v1-localname))) ;; When newname did exist, we have wrong cached values. (when t2 (with-parsed-tramp-file-name newname v2 - (tramp-flush-file-property v2 (file-name-directory v2-localname)) - (tramp-flush-file-property v2 v2-localname)))))))) + (tramp-flush-file-properties + v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname)))))))) (defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date) "Use an Emacs buffer to copy or rename a file. @@ -2197,8 +2143,8 @@ the uid and gid from FILENAME." v 'file-error "Unknown operation `%s', must be `copy' or `rename'" op)))) - (localname1 (if t1 (file-remote-p filename 'localname) filename)) - (localname2 (if t2 (file-remote-p newname 'localname) newname)) + (localname1 (tramp-compat-file-local-name filename)) + (localname2 (tramp-compat-file-local-name newname)) (prefix (file-remote-p (if t1 filename newname))) cmd-result) (when (and (eq op 'copy) (file-directory-p filename)) @@ -2236,8 +2182,7 @@ the uid and gid from FILENAME." (or (eq op 'copy) (zerop (logand - (file-modes (file-name-directory localname1)) - (string-to-number "1000" 8)))) + (file-modes (file-name-directory localname1)) #o1000))) (file-writable-p (file-name-directory localname2)) (or (file-directory-p localname2) (file-writable-p localname2)))) @@ -2246,7 +2191,8 @@ the uid and gid from FILENAME." localname1 localname2 ok-if-already-exists keep-date preserve-uid-gid) (tramp-run-real-handler - 'rename-file (list localname1 localname2 ok-if-already-exists)))) + #'rename-file + (list localname1 localname2 ok-if-already-exists)))) ;; We can do it directly with `tramp-send-command' ((and (file-readable-p (concat prefix localname1)) @@ -2281,8 +2227,7 @@ the uid and gid from FILENAME." ;; We must change the ownership as remote user. ;; Since this does not work reliable, we also ;; give read permissions. - (set-file-modes - (concat prefix tmpfile) (string-to-number "0777" 8)) + (set-file-modes (concat prefix tmpfile) #o0777) (tramp-set-file-uid-gid (concat prefix tmpfile) (tramp-get-local-uid 'integer) @@ -2292,11 +2237,11 @@ the uid and gid from FILENAME." (copy-file localname1 tmpfile t keep-date preserve-uid-gid) (tramp-run-real-handler - 'rename-file (list localname1 tmpfile t))) + #'rename-file (list localname1 tmpfile t))) ;; We must change the ownership as local user. ;; Since this does not work reliable, we also ;; give read permissions. - (set-file-modes tmpfile (string-to-number "0777" 8)) + (set-file-modes tmpfile #o0777) (tramp-set-file-uid-gid tmpfile (tramp-get-remote-uid v 'integer) @@ -2314,7 +2259,7 @@ the uid and gid from FILENAME." (tramp-get-buffer v))) (t1 (tramp-run-real-handler - 'rename-file + #'rename-file (list tmpfile localname2 ok-if-already-exists))))) ;; Save exit. @@ -2359,21 +2304,13 @@ The method used must be an out-of-band method." (expand-file-name ".." tmpfile) 'recursive) (delete-file tmpfile))))) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method (tramp-file-name-method v) - tramp-current-user (or (tramp-file-name-user v) - (tramp-get-connection-property - v "login-as" nil)) - tramp-current-domain (tramp-file-name-domain v) - tramp-current-host (tramp-file-name-host v) - tramp-current-port (tramp-file-name-port v)) - ;; Check which ones of source and target are Tramp files. (setq source (funcall - (if (and (file-directory-p filename) + (if (and (string-equal method "rsync") + (file-directory-p filename) (not (file-exists-p newname))) - 'file-name-as-directory - 'identity) + #'file-name-as-directory + #'identity) (if t1 (tramp-make-copy-program-file-name v) (tramp-unquote-shell-quote-argument filename))) @@ -2427,7 +2364,7 @@ The method used must be an out-of-band method." (mapcar (lambda (x) (setq x (mapcar (lambda (y) (format-spec y spec)) x)) - (unless (member "" x) (mapconcat 'identity x " "))) + (unless (member "" x) (string-join x " "))) (tramp-get-method-parameter v 'tramp-copy-env))) remote-copy-program @@ -2457,7 +2394,7 @@ The method used must be an out-of-band method." "Cannot find remote listener: %s" remote-copy-program)) (setq remote-copy-program (mapconcat - 'identity + #'identity (append (list remote-copy-program) remote-copy-args (list (if t1 (concat "<" source) (concat ">" target)) "&")) @@ -2478,9 +2415,7 @@ The method used must be an out-of-band method." ;; The default directory must be remote. (let ((default-directory (file-name-directory (if t1 filename newname))) - (process-environment (copy-sequence process-environment)) - ;; We do not want to run timers. - timer-list timer-idle-list) + (process-environment (copy-sequence process-environment))) ;; Set the transfer process properties. (tramp-set-connection-property v "process-name" (buffer-name (current-buffer))) @@ -2503,7 +2438,7 @@ The method used must be an out-of-band method." ;; copying of large files can last longer than 60 secs. (let* ((command (mapconcat - 'identity (append (list copy-program) copy-args) + #'identity (append (list copy-program) copy-args) " ")) (p (let ((default-directory (tramp-compat-temporary-file-directory))) @@ -2512,8 +2447,8 @@ The method used must be an out-of-band method." (tramp-get-connection-buffer v) command)))) (tramp-message orig-vec 6 "%s" command) - (tramp-set-connection-property p "vector" orig-vec) - (process-put p 'adjust-window-size-function 'ignore) + (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 @@ -2523,8 +2458,8 @@ The method used must be an out-of-band method." p v nil tramp-actions-copy-out-of-band)))) ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") ;; Clear the remote prompt. (when (and remote-copy-program (not (tramp-send-command-and-check v nil))) @@ -2555,20 +2490,23 @@ The method used must be an out-of-band method." "Like `make-directory' for Tramp files." (setq dir (expand-file-name dir)) (with-parsed-tramp-file-name dir nil - (tramp-flush-directory-property v (file-name-directory localname)) - (save-excursion - (tramp-barf-unless-okay - v (format "%s %s" - (if parents "mkdir -p" "mkdir") - (tramp-shell-quote-argument localname)) - "Couldn't make directory %s" dir)))) + ;; 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 cache. + (tramp-flush-directory-properties + v (if parents "/" (file-name-directory localname))) + (tramp-barf-unless-okay + v (format "%s %s" + (if parents "mkdir -p" "mkdir") + (tramp-shell-quote-argument localname)) + "Couldn't make directory %s" dir))) (defun tramp-sh-handle-delete-directory (directory &optional recursive trash) "Like `delete-directory' for Tramp files." (setq directory (expand-file-name directory)) (with-parsed-tramp-file-name directory nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (tramp-barf-unless-okay v (format "cd / && %s %s" (or (and trash (tramp-get-remote-trash v)) @@ -2580,8 +2518,8 @@ The method used must be an out-of-band method." "Like `delete-file' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (tramp-barf-unless-okay v (format "%s %s" (or (and trash (tramp-get-remote-trash v)) "rm -f") @@ -2594,48 +2532,49 @@ The method used must be an out-of-band method." "Like `dired-compress-file' for Tramp files." ;; Code stolen mainly from dired-aux.el. (with-parsed-tramp-file-name file nil - (tramp-flush-file-property v localname) - (save-excursion - (let ((suffixes dired-compress-file-suffixes) - suffix) - ;; See if any suffix rule matches this file name. - (while suffixes - (let (case-fold-search) - (if (string-match (car (car suffixes)) localname) - (setq suffix (car suffixes) suffixes nil)) - (setq suffixes (cdr suffixes)))) - - (cond ((file-symlink-p file) - nil) - ((and suffix (nth 2 suffix)) - ;; We found an uncompression rule. - (with-tramp-progress-reporter - v 0 (format "Uncompressing %s" file) - (when (tramp-send-command-and-check - v (concat (nth 2 suffix) " " - (tramp-shell-quote-argument localname))) - (dired-remove-file file) - (string-match (car suffix) file) - (concat (substring file 0 (match-beginning 0)))))) - (t - ;; We don't recognize the file as compressed, so compress it. - ;; Try gzip. - (with-tramp-progress-reporter v 0 (format "Compressing %s" file) - (when (tramp-send-command-and-check - v (concat "gzip -f " - (tramp-shell-quote-argument localname))) - (dired-remove-file file) - (cond ((file-exists-p (concat file ".gz")) - (concat file ".gz")) - ((file-exists-p (concat file ".z")) - (concat file ".z")) - (t nil)))))))))) + (tramp-flush-file-properties v localname) + (let ((suffixes dired-compress-file-suffixes) + suffix) + ;; See if any suffix rule matches this file name. + (while suffixes + (let (case-fold-search) + (if (string-match-p (car (car suffixes)) localname) + (setq suffix (car suffixes) suffixes nil)) + (setq suffixes (cdr suffixes)))) + + (cond ((file-symlink-p file) nil) + ((and suffix (nth 2 suffix)) + ;; We found an uncompression rule. + (with-tramp-progress-reporter + v 0 (format "Uncompressing %s" file) + (when (tramp-send-command-and-check + v (concat (nth 2 suffix) " " + (tramp-shell-quote-argument localname))) + (dired-remove-file file) + (string-match (car suffix) file) + (concat (substring file 0 (match-beginning 0)))))) + (t + ;; We don't recognize the file as compressed, so compress it. + ;; Try gzip. + (with-tramp-progress-reporter v 0 (format "Compressing %s" file) + (when (tramp-send-command-and-check + v (concat "gzip -f " + (tramp-shell-quote-argument localname))) + (dired-remove-file file) + (cond ((file-exists-p (concat file ".gz")) + (concat file ".gz")) + ((file-exists-p (concat file ".z")) + (concat file ".z")) + (t nil))))))))) (defun tramp-sh-handle-insert-directory (filename switches &optional wildcard full-directory-p) "Like `insert-directory' for Tramp files." (setq filename (expand-file-name filename)) (unless switches (setq switches "")) + ;; Check, whether directory is accessible. + (unless wildcard + (access-file filename "Reading directory")) (with-parsed-tramp-file-name filename nil (if (and (featurep 'ls-lisp) (not (symbol-value 'ls-lisp-use-insert-directory-program))) @@ -2643,19 +2582,21 @@ The method used must be an out-of-band method." filename switches wildcard full-directory-p) (when (stringp switches) (setq switches (split-string switches))) - (when (tramp-get-ls-command-with-quoting-style v) - (setq switches (append switches '("--quoting-style=literal")))) - (when (and (member "--dired" switches) - (not (tramp-get-ls-command-with-dired v))) + (when (tramp-get-ls-command-with ;FIXME: tramp-sh--quoting-style-options? + v "--quoting-style=literal --show-control-chars") + (setq switches + (append + switches '("--quoting-style=literal" "--show-control-chars")))) + (unless (tramp-get-ls-command-with v "--dired") (setq switches (delete "--dired" switches))) (when wildcard (setq wildcard (tramp-run-real-handler - 'file-name-nondirectory (list localname))) + #'file-name-nondirectory (list localname))) (setq localname (tramp-run-real-handler - 'file-name-directory (list localname)))) + #'file-name-directory (list localname)))) (unless (or full-directory-p (member "-d" switches)) (setq switches (append switches '("-d")))) - (setq switches (mapconcat 'tramp-shell-quote-argument switches " ")) + (setq switches (mapconcat #'tramp-shell-quote-argument switches " ")) (when wildcard (setq switches (concat switches " " wildcard))) (tramp-message @@ -2677,10 +2618,10 @@ The method used must be an out-of-band method." v (format "cd %s" (tramp-shell-quote-argument (tramp-run-real-handler - 'file-name-directory (list localname)))) + #'file-name-directory (list localname)))) "Couldn't `cd %s'" (tramp-shell-quote-argument - (tramp-run-real-handler 'file-name-directory (list localname)))) + (tramp-run-real-handler #'file-name-directory (list localname)))) (tramp-send-command v (format "%s %s %s 2>/dev/null" @@ -2689,11 +2630,11 @@ The method used must be an out-of-band method." (if (or wildcard (zerop (length (tramp-run-real-handler - 'file-name-nondirectory (list localname))))) + #'file-name-nondirectory (list localname))))) "" (tramp-shell-quote-argument (tramp-run-real-handler - 'file-name-nondirectory (list localname))))))) + #'file-name-nondirectory (list localname))))))) (save-restriction (let ((beg (point))) @@ -2707,7 +2648,7 @@ The method used must be an out-of-band method." ;; Check for "--dired" output. (forward-line -2) - (when (looking-at "//SUBDIRED//") + (when (looking-at-p "//SUBDIRED//") (forward-line -1)) (when (looking-at "//DIRED//\\s-+") (let ((databeg (match-end 0)) @@ -2728,7 +2669,7 @@ The method used must be an out-of-band method." ;; Some busyboxes are reluctant to discard colors. (unless - (string-match "color" (tramp-get-connection-property v "ls" "")) + (string-match-p "color" (tramp-get-connection-property v "ls" "")) (goto-char beg) (while (re-search-forward tramp-display-escape-sequence-regexp nil t) @@ -2772,15 +2713,17 @@ If the localname part of the given file name starts with \"/../\" then the result will be a local, non-Tramp, file name." ;; If DIR is not given, use `default-directory' or "/". (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)) + (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)) + (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 @@ -2796,7 +2739,7 @@ the result will be a local, non-Tramp, file name." ;; appropriate either, because ssh and companions might ;; use a user name from the config file. (when (and (string-equal uname "~") - (string-match "\\`su\\(do\\)?\\'" method)) + (string-match-p "\\`su\\(do\\)?\\'" method)) (setq uname (concat uname user))) (setq uname (with-tramp-connection-property v uname @@ -2816,165 +2759,210 @@ the result will be a local, non-Tramp, file name." ;; be problems with UNC shares or Cygwin mounts. (let ((default-directory (tramp-compat-temporary-file-directory))) (tramp-make-tramp-file-name - method user domain host port - (tramp-drop-volume-letter - (tramp-run-real-handler - 'expand-file-name (list localname))) - hop))))) + v (tramp-drop-volume-letter + (tramp-run-real-handler + #'expand-file-name (list localname)))))))) ;;; Remote commands: -(defun tramp-process-sentinel (proc event) - "Flush file caches." - (unless (process-live-p proc) - (let ((vec (tramp-get-connection-property proc "vector" nil))) - (when vec - (tramp-message vec 5 "Sentinel called: `%S' `%s'" proc event) - (tramp-flush-connection-property proc) - (tramp-flush-directory-property vec ""))))) - ;; 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. -(defun tramp-sh-handle-start-file-process (name buffer program &rest args) - "Like `start-file-process' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name default-directory) nil - (let* ((buffer - (if buffer - (get-buffer-create buffer) - ;; BUFFER can be nil. We use a temporary buffer. - (generate-new-buffer tramp-temp-buffer-name))) - ;; When PROGRAM matches "*sh", and the first arg is "-c", - ;; it might be that the arguments exceed the command line - ;; length. Therefore, we modify the command. - (heredoc (and (stringp program) - (string-match "sh$" program) - (string-equal "-c" (car args)) - (= (length args) 2))) - ;; When PROGRAM is nil, we just provide a tty. - (args (if (not heredoc) args - (let ((i 250)) - (while (and (< i (length (cadr args))) - (string-match " " (cadr args) i)) - (setcdr - args - (list (replace-match " \\\\\n" nil nil (cadr args)))) - (setq i (+ i 250)))) - (cdr args))) - ;; Use a human-friendly prompt, for example for `shell'. - ;; We discard hops, if existing, that's why we cannot use - ;; `file-remote-p'. - (prompt (format "PS1=%s %s" - (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-domain v) - (tramp-file-name-host v) - (tramp-file-name-port v) - (tramp-file-name-localname v)) - tramp-initial-end-of-output)) - ;; We use as environment the difference to toplevel - ;; `process-environment'. - env uenv - (env (dolist (elt (cons prompt process-environment) env) - (or (member elt (default-toplevel-value 'process-environment)) - (if (string-match "=" 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))))))) - (command - (when (stringp program) - (format "cd %s && %s exec %s env %s %s" - (tramp-shell-quote-argument localname) - (if uenv - (format - "unset %s &&" - (mapconcat 'tramp-shell-quote-argument uenv " ")) - "") - (if heredoc (format "<<'%s'" tramp-end-of-heredoc) "") - (mapconcat 'tramp-shell-quote-argument env " ") - (if heredoc - (format "%s\n(\n%s\n) </dev/tty\n%s" - program (car args) tramp-end-of-heredoc) - (mapconcat 'tramp-shell-quote-argument - (cons program args) " "))))) - (tramp-process-connection-type - (or (null program) tramp-process-connection-type)) - (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) - (name1 name) - (i 0) - ;; We do not want to raise an error when - ;; `start-file-process' has been started several times in - ;; `eshell' and friends. - tramp-current-connection - ;; We do not want to run timers. - timer-list timer-idle-list - p) - - (while (get-process name1) - ;; NAME must be unique as process name. - (setq i (1+ i) - name1 (format "%s<%d>" name i))) - (setq name name1) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) - - (with-current-buffer (tramp-get-connection-buffer v) - (unwind-protect - ;; We catch this event. Otherwise, `start-process' could - ;; be called on the local host. - (save-excursion - (save-restriction - ;; Activate narrowing in order to save BUFFER - ;; contents. Clear also the modification time; - ;; otherwise we might be interrupted by - ;; `verify-visited-file-modtime'. - (let ((buffer-undo-list t) - (buffer-read-only nil) - (mark (point-max))) - (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 $$"))) - (process-put p 'remote-pid pid) - (tramp-set-connection-property p "remote-pid" pid)) - (widen) - (delete-region mark (point-max)) - (narrow-to-region (point-max) (point-max)) - ;; Now do it. - (if command - ;; Send the command. - (tramp-send-command v command nil t) ; nooutput - ;; Check, whether a pty is associated. - (unless (process-get p 'remote-tty) - (tramp-error - v 'file-error - "pty association is not supported for `%s'" name)))) - ;; Set query flag and process marker for this - ;; process. We ignore errors, because the process - ;; could have finished already. - (ignore-errors - (set-process-query-on-exit-flag p t) - (set-marker (process-mark p) (point))) - ;; Return process. - p))) +(defun tramp-sh-handle-make-process (&rest args) + "Like `make-process' for Tramp files." + (when args + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let ((name (plist-get args :name)) + (buffer (plist-get args :buffer)) + (command (plist-get args :command)) + (coding (plist-get args :coding)) + (noquery (plist-get args :noquery)) + (connection-type (plist-get args :connection-type)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + (stderr (plist-get args :stderr))) + (unless (stringp name) + (signal 'wrong-type-argument (list #'stringp name))) + (unless (or (null buffer) (bufferp buffer) (stringp buffer)) + (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (consp command) + (signal 'wrong-type-argument (list #'consp command))) + (unless (or (null coding) + (and (symbolp coding) (memq coding coding-system-list)) + (and (consp coding) + (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))) + (signal 'wrong-type-argument (list #'symbolp connection-type))) + (unless (or (null filter) (functionp filter)) + (signal 'wrong-type-argument (list #'functionp filter))) + (unless (or (null sentinel) (functionp sentinel)) + (signal 'wrong-type-argument (list #'functionp sentinel))) + (unless (or (null stderr) (bufferp stderr) (stringp stderr)) + (signal 'wrong-type-argument (list #'stringp stderr))) + + (let* ((buffer + (if buffer + (get-buffer-create buffer) + ;; BUFFER can be nil. We use a temporary buffer. + (generate-new-buffer tramp-temp-buffer-name))) + (stderr (and stderr (get-buffer-create stderr))) + (tmpstderr (and stderr (tramp-make-tramp-temp-file v))) + (program (car command)) + (args (cdr command)) + ;; When PROGRAM matches "*sh", and the first arg is + ;; "-c", it might be that the arguments exceed the + ;; command line length. Therefore, we modify the + ;; command. + (heredoc (and (stringp program) + (string-match-p "sh$" program) + (string-equal "-c" (car args)) + (= (length args) 2))) + ;; When PROGRAM is nil, we just provide a tty. + (args (if (not heredoc) args + (let ((i 250)) + (while (and (< i (length (cadr args))) + (string-match " " (cadr args) i)) + (setcdr + args + (list + (replace-match " \\\\\n" nil nil (cadr args)))) + (setq i (+ i 250)))) + (cdr args))) + ;; Use a human-friendly prompt, for example for + ;; `shell'. We discard hops, if existing, that's why + ;; we cannot use `file-remote-p'. + (prompt (format "PS1=%s %s" + (tramp-make-tramp-file-name v nil 'nohop) + tramp-initial-end-of-output)) + ;; We use as environment the difference to toplevel + ;; `process-environment'. + env uenv + (env (dolist (elt (cons prompt process-environment) env) + (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))))))) + (command + (when (stringp program) + (format "cd %s && %s exec %s %s env %s %s" + (tramp-shell-quote-argument localname) + (if uenv + (format + "unset %s &&" + (mapconcat + #'tramp-shell-quote-argument uenv " ")) + "") + (if heredoc (format "<<'%s'" tramp-end-of-heredoc) "") + (if tmpstderr (format "2>'%s'" tmpstderr) "") + (mapconcat #'tramp-shell-quote-argument env " ") + (if heredoc + (format "%s\n(\n%s\n) </dev/tty\n%s" + program (car args) tramp-end-of-heredoc) + (mapconcat #'tramp-shell-quote-argument + (cons program args) " "))))) + (tramp-process-connection-type + (or (null program) tramp-process-connection-type)) + (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) + (name1 name) + (i 0) + ;; We do not want to raise an error when `make-process' + ;; has been started several times in `eshell' and + ;; friends. + tramp-current-connection + p) + + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + (setq name name1) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) - ;; Save exit. - (if (string-match tramp-temp-buffer-name (buffer-name)) - (ignore-errors - (set-process-buffer p nil) - (kill-buffer (current-buffer))) - (set-buffer-modified-p bmp)) - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil)))))) + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + ;; We catch this event. Otherwise, `make-process' could + ;; be called on the local host. + (save-excursion + (save-restriction + ;; Activate narrowing in order to save BUFFER + ;; contents. Clear also the modification time; + ;; otherwise we might be interrupted by + ;; `verify-visited-file-modtime'. + (let ((buffer-undo-list t) + (inhibit-read-only t) + (mark (point-max))) + (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 $$"))) + (process-put p 'remote-pid pid) + (tramp-set-connection-property p "remote-pid" pid)) + ;; `tramp-maybe-open-connection' and + ;; `tramp-send-command-and-read' could have + ;; trashed the connection buffer. Remove this. + (widen) + (delete-region mark (point-max)) + (narrow-to-region (point-max) (point-max)) + ;; Now do it. + (if command + ;; Send the command. + (tramp-send-command v command nil t) ; nooutput + ;; Check, whether a pty is associated. + (unless (process-get p 'remote-tty) + (tramp-error + v 'file-error + "pty association is not supported for `%s'" + name)))) + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + ;; Set query flag and process marker for this + ;; process. We ignore errors, because the + ;; process could have finished already. + (ignore-errors + (set-process-query-on-exit-flag p (null noquery)) + (set-marker (process-mark p) (point))) + ;; Provide error buffer. This shows only + ;; initial error messages; messages arriving + ;; later on shall be inserted by `auto-revert'. + ;; The temporary file will still be existing. + ;; TODO: Write a sentinel, which deletes the + ;; temporary file. + (when tmpstderr + ;; We must flush them here already; otherwise + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + (with-current-buffer stderr + (insert-file-contents + (tramp-make-tramp-file-name v tmpstderr) 'visit) + (auto-revert-mode))) + ;; Return process. + p))) + + ;; Save exit. + (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (ignore-errors + (set-process-buffer p nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp)) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer")))))))) (defun tramp-sh-handle-process-file (program &optional infile destination display &rest args) @@ -2986,12 +2974,12 @@ the result will be a local, non-Tramp, file name." (with-parsed-tramp-file-name default-directory nil (let (command env uenv input tmpinput stderr tmpstderr outbuf ret) ;; Compute command. - (setq command (mapconcat 'tramp-shell-quote-argument + (setq command (mapconcat #'tramp-shell-quote-argument (cons program args) " ")) ;; 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 "=" elt) + (if (string-match-p "=" elt) (setq env (append env `(,elt))) (if (tramp-get-env-with-u-option v) (setq env (append `("-u" ,elt) env)) @@ -3000,12 +2988,12 @@ the result will be a local, non-Tramp, file name." (setq command (format "env %s %s" - (mapconcat 'tramp-shell-quote-argument env " ") command))) + (mapconcat #'tramp-shell-quote-argument env " ") command))) (when uenv (setq command (format "unset %s && %s" - (mapconcat 'tramp-shell-quote-argument uenv " ") command))) + (mapconcat #'tramp-shell-quote-argument uenv " ") command))) ;; Determine input. (if (null infile) (setq input "/dev/null") @@ -3015,8 +3003,7 @@ the result will be a local, non-Tramp, file name." (setq input (with-parsed-tramp-file-name infile nil localname)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) - tmpinput - (tramp-make-tramp-file-name method user domain host port input)) + tmpinput (tramp-make-tramp-file-name v input 'nohop)) (copy-file infile tmpinput t))) (when input (setq command (format "%s <%s" command input))) @@ -3049,8 +3036,7 @@ the result will be a local, non-Tramp, file name." ;; stderr must be copied to remote host. The temporary ;; file must be deleted after execution. (setq stderr (tramp-make-tramp-temp-file v) - tmpstderr (tramp-make-tramp-file-name - method user domain host port stderr)))) + tmpstderr (tramp-make-tramp-file-name v stderr 'nohop)))) ;; stderr to be discarded. ((null (cadr destination)) (setq stderr "/dev/null")))) @@ -3096,13 +3082,20 @@ the result will be a local, non-Tramp, file name." (when tmpinput (delete-file tmpinput)) (unless process-file-side-effects - (tramp-flush-directory-property v "")) + (tramp-flush-directory-properties v "")) ;; Return exit status. (if (equal ret -1) (keyboard-quit) ret)))) +(defun tramp-sh-handle-exec-path () + "Like `exec-path' for Tramp files." + (append + (tramp-get-remote-path (tramp-dissect-file-name default-directory)) + ;; The equivalent to `exec-directory'. + `(,(tramp-compat-file-local-name default-directory)))) + (defun tramp-sh-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil @@ -3126,50 +3119,49 @@ the result will be a local, non-Tramp, file name." ;; Use inline encoding for file transfer. (rem-enc - (save-excursion - (with-tramp-progress-reporter - v 3 - (format-message "Encoding remote file `%s' with `%s'" - filename rem-enc) - (tramp-barf-unless-okay - v (format rem-enc (tramp-shell-quote-argument localname)) - "Encoding remote file failed")) - - (with-tramp-progress-reporter - v 3 (format-message "Decoding local file `%s' with `%s'" - tmpfile loc-dec) - (if (functionp loc-dec) - ;; If local decoding is a function, we call it. - ;; We must disable multibyte, because - ;; `uudecode-decode-region' doesn't handle it - ;; correctly. Unset `file-name-handler-alist'. - ;; Otherwise, epa-file gets confused. - (let (file-name-handler-alist - (coding-system-for-write 'binary)) - (with-temp-file tmpfile - (set-buffer-multibyte nil) - (insert-buffer-substring (tramp-get-buffer v)) - (funcall loc-dec (point-min) (point-max)))) - - ;; If tramp-decoding-function is not defined for this - ;; method, we invoke tramp-decoding-command instead. - (let ((tmpfile2 (tramp-compat-make-temp-file filename))) - ;; Unset `file-name-handler-alist'. Otherwise, - ;; epa-file gets confused. - (let (file-name-handler-alist - (coding-system-for-write 'binary)) - (with-current-buffer (tramp-get-buffer v) - (write-region - (point-min) (point-max) tmpfile2 nil 'no-message))) - (unwind-protect - (tramp-call-local-coding-command - loc-dec tmpfile2 tmpfile) - (delete-file tmpfile2))))) - - ;; Set proper permissions. - (set-file-modes tmpfile (tramp-default-file-modes filename)) - ;; Set local user ownership. - (tramp-set-file-uid-gid tmpfile))) + (with-tramp-progress-reporter + v 3 + (format-message + "Encoding remote file `%s' with `%s'" filename rem-enc) + (tramp-barf-unless-okay + v (format rem-enc (tramp-shell-quote-argument localname)) + "Encoding remote file failed")) + + (with-tramp-progress-reporter + v 3 (format-message + "Decoding local file `%s' with `%s'" tmpfile loc-dec) + (if (functionp loc-dec) + ;; If local decoding is a function, we call it. We + ;; must disable multibyte, because + ;; `uudecode-decode-region' doesn't handle it + ;; correctly. Unset `file-name-handler-alist'. + ;; Otherwise, epa-file gets confused. + (let (file-name-handler-alist + (coding-system-for-write 'binary)) + (with-temp-file tmpfile + (set-buffer-multibyte nil) + (insert-buffer-substring (tramp-get-buffer v)) + (funcall loc-dec (point-min) (point-max)))) + + ;; If tramp-decoding-function is not defined for this + ;; method, we invoke tramp-decoding-command instead. + (let ((tmpfile2 (tramp-compat-make-temp-file filename))) + ;; Unset `file-name-handler-alist'. Otherwise, + ;; epa-file gets confused. + (let (file-name-handler-alist + (coding-system-for-write 'binary)) + (with-current-buffer (tramp-get-buffer v) + (write-region + (point-min) (point-max) tmpfile2 nil 'no-message))) + (unwind-protect + (tramp-call-local-coding-command + loc-dec tmpfile2 tmpfile) + (delete-file tmpfile2))))) + + ;; Set proper permissions. + (set-file-modes tmpfile (tramp-default-file-modes filename)) + ;; Set local user ownership. + (tramp-set-file-uid-gid tmpfile)) ;; Oops, I don't know what to do. (t (tramp-error @@ -3213,7 +3205,8 @@ the result will be a local, non-Tramp, file name." (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 + (list start end localname append 'no-message lockname)) (let* ((modes (save-excursion (tramp-default-file-modes filename))) ;; We use this to save the value of @@ -3249,7 +3242,7 @@ the result will be a local, non-Tramp, file name." (tramp-find-file-name-coding-system-alist filename tmpfile))) (condition-case err (tramp-run-real-handler - 'write-region + #'write-region (list start end tmpfile append 'no-message lockname)) ((error quit) (setq tramp-temp-buffer-file-name nil) @@ -3265,9 +3258,7 @@ the result will be a local, non-Tramp, file name." ;; handles permissions. ;; Ensure that it is still readable. (when modes - (set-file-modes - tmpfile - (logior (or modes 0) (string-to-number "0400" 8)))) + (set-file-modes tmpfile (logior (or modes 0) #o0400))) ;; This is a bit lengthy due to the different methods ;; possible for file transfer. First, we check whether the @@ -3335,8 +3326,9 @@ the result will be a local, non-Tramp, file name." loc-enc tmpfile t)) (tramp-error v 'file-error - (concat "Cannot write to `%s', " - "local encoding command `%s' failed") + (eval-when-compile + (concat "Cannot write to `%s', " + "local encoding command `%s' failed")) filename loc-enc)))) ;; Send buffer into remote decoding command which @@ -3381,8 +3373,9 @@ the result will be a local, non-Tramp, file name." (buffer-string)))) (tramp-error v 'file-error - (concat "Couldn't write region to `%s'," - " decode using `%s' failed") + (eval-when-compile + (concat "Couldn't write region to `%s'," + " decode using `%s' failed")) filename rem-dec))))) ;; Save exit. @@ -3392,16 +3385,17 @@ the result will be a local, non-Tramp, file name." (t (tramp-error v 'file-error - (concat "Method `%s' should specify both encoding and " - "decoding command or an scp program") + (eval-when-compile + (concat "Method `%s' should specify both encoding and " + "decoding command or an scp program")) method)))) ;; Make `last-coding-system-used' have the right value. (when coding-system-used (set 'last-coding-system-used coding-system-used)))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) ;; We must protect `last-coding-system-used', now we have set it ;; to its correct value. @@ -3444,88 +3438,89 @@ the result will be a local, non-Tramp, file name." ;; any other remote command. (defun tramp-sh-handle-vc-registered (file) "Like `vc-registered' for Tramp files." - (with-temp-message "" - (with-parsed-tramp-file-name file nil - (with-tramp-progress-reporter - v 3 (format-message "Checking `vc-registered' for %s" file) - - ;; There could be new files, created by the vc backend. We - ;; cannot reuse the old cache entries, therefore. In - ;; `tramp-get-file-property', `remote-file-name-inhibit-cache' - ;; could also be a timestamp as `current-time' returns. This - ;; means invalidate all cache entries with an older timestamp. - (let (tramp-vc-registered-file-names - (remote-file-name-inhibit-cache (current-time)) - (file-name-handler-alist - `((,tramp-file-name-regexp . tramp-vc-file-name-handler)))) - - ;; Here we collect only file names, which need an operation. - (tramp-with-demoted-errors - v "Error in 1st pass of `vc-registered': %s" - (tramp-run-real-handler 'vc-registered (list file))) - (tramp-message v 10 "\n%s" tramp-vc-registered-file-names) - - ;; Send just one command, in order to fill the cache. - (when tramp-vc-registered-file-names - (tramp-maybe-send-script - v - (format tramp-vc-registered-read-file-names - (tramp-get-file-exists-command v) - (format "%s -r" (tramp-get-test-command v))) - "tramp_vc_registered_read_file_names") - - (dolist - (elt - (ignore-errors - ;; We cannot use `tramp-send-command-and-read', - ;; because this does not cooperate well with - ;; heredoc documents. - (tramp-send-command - v - (format - "tramp_vc_registered_read_file_names <<'%s'\n%s\n%s\n" - tramp-end-of-heredoc - (mapconcat 'tramp-shell-quote-argument - tramp-vc-registered-file-names - "\n") - tramp-end-of-heredoc)) - (with-current-buffer (tramp-get-connection-buffer v) - ;; Read the expression. - (goto-char (point-min)) - (read (current-buffer))))) - - (tramp-set-file-property - v (car elt) (cadr elt) (cadr (cdr elt)))))) - - ;; Second run. Now all `file-exists-p' or `file-readable-p' - ;; calls shall be answered from the file cache. We unset - ;; `process-file-side-effects' and `remote-file-name-inhibit-cache' - ;; in order to keep the cache. - (let ((vc-handled-backends vc-handled-backends) - remote-file-name-inhibit-cache process-file-side-effects) - ;; Reduce `vc-handled-backends' in order to minimize process calls. - (when (and (memq 'Bzr vc-handled-backends) - (boundp 'vc-bzr-program) - (not (with-tramp-connection-property v vc-bzr-program - (tramp-find-executable - v vc-bzr-program (tramp-get-remote-path v))))) - (setq vc-handled-backends (remq 'Bzr vc-handled-backends))) - (when (and (memq 'Git vc-handled-backends) - (boundp 'vc-git-program) - (not (with-tramp-connection-property v vc-git-program - (tramp-find-executable - v vc-git-program (tramp-get-remote-path v))))) - (setq vc-handled-backends (remq 'Git vc-handled-backends))) - (when (and (memq 'Hg vc-handled-backends) - (boundp 'vc-hg-program) - (not (with-tramp-connection-property v vc-hg-program - (tramp-find-executable - v vc-hg-program (tramp-get-remote-path v))))) - (setq vc-handled-backends (remq 'Hg vc-handled-backends))) - ;; Run. - (tramp-with-demoted-errors - v "Error in 2nd pass of `vc-registered': %s" - (tramp-run-real-handler 'vc-registered (list file)))))))) + (when vc-handled-backends + (with-temp-message "" + (with-parsed-tramp-file-name file nil + (with-tramp-progress-reporter + v 3 (format-message "Checking `vc-registered' for %s" file) + + ;; There could be new files, created by the vc backend. We + ;; cannot reuse the old cache entries, therefore. In + ;; `tramp-get-file-property', `remote-file-name-inhibit-cache' + ;; could also be a timestamp as `current-time' returns. This + ;; means invalidate all cache entries with an older timestamp. + (let (tramp-vc-registered-file-names + (remote-file-name-inhibit-cache (current-time)) + (file-name-handler-alist + `((,tramp-file-name-regexp . tramp-vc-file-name-handler)))) + + ;; Here we collect only file names, which need an operation. + (tramp-with-demoted-errors + v "Error in 1st pass of `vc-registered': %s" + (tramp-run-real-handler #'vc-registered (list file))) + (tramp-message v 10 "\n%s" tramp-vc-registered-file-names) + + ;; Send just one command, in order to fill the cache. + (when tramp-vc-registered-file-names + (tramp-maybe-send-script + v + (format tramp-vc-registered-read-file-names + (tramp-get-file-exists-command v) + (format "%s -r" (tramp-get-test-command v))) + "tramp_vc_registered_read_file_names") + + (dolist + (elt + (ignore-errors + ;; We cannot use `tramp-send-command-and-read', + ;; because this does not cooperate well with + ;; heredoc documents. + (tramp-send-command + v + (format + "tramp_vc_registered_read_file_names <<'%s'\n%s\n%s\n" + tramp-end-of-heredoc + (mapconcat #'tramp-shell-quote-argument + tramp-vc-registered-file-names + "\n") + tramp-end-of-heredoc)) + (with-current-buffer (tramp-get-connection-buffer v) + ;; Read the expression. + (goto-char (point-min)) + (read (current-buffer))))) + + (tramp-set-file-property + v (car elt) (cadr elt) (cadr (cdr elt)))))) + + ;; Second run. Now all `file-exists-p' or `file-readable-p' + ;; calls shall be answered from the file cache. We unset + ;; `process-file-side-effects' and `remote-file-name-inhibit-cache' + ;; in order to keep the cache. + (let ((vc-handled-backends vc-handled-backends) + remote-file-name-inhibit-cache process-file-side-effects) + ;; Reduce `vc-handled-backends' in order to minimize process calls. + (when (and (memq 'Bzr vc-handled-backends) + (boundp 'vc-bzr-program) + (not (with-tramp-connection-property v vc-bzr-program + (tramp-find-executable + v vc-bzr-program (tramp-get-remote-path v))))) + (setq vc-handled-backends (remq 'Bzr vc-handled-backends))) + (when (and (memq 'Git vc-handled-backends) + (boundp 'vc-git-program) + (not (with-tramp-connection-property v vc-git-program + (tramp-find-executable + v vc-git-program (tramp-get-remote-path v))))) + (setq vc-handled-backends (remq 'Git vc-handled-backends))) + (when (and (memq 'Hg vc-handled-backends) + (boundp 'vc-hg-program) + (not (with-tramp-connection-property v vc-hg-program + (tramp-find-executable + v vc-hg-program (tramp-get-remote-path v))))) + (setq vc-handled-backends (remq 'Hg vc-handled-backends))) + ;; Run. + (tramp-with-demoted-errors + v "Error in 2nd pass of `vc-registered': %s" + (tramp-run-real-handler #'vc-registered (list file))))))))) ;;;###tramp-autoload (defun tramp-sh-file-name-handler (operation &rest args) @@ -3538,34 +3533,40 @@ Fall back to normal file name handler if no Tramp handler exists." ;; This must be the last entry, because `identity' always matches. ;;;###tramp-autoload -(tramp-register-foreign-file-name-handler - 'identity 'tramp-sh-file-name-handler 'append) +(tramp--with-startup + (tramp-register-foreign-file-name-handler + #'identity #'tramp-sh-file-name-handler 'append)) (defun tramp-vc-file-name-handler (operation &rest args) "Invoke special file name handler, which collects files to be handled." (save-match-data (let ((filename (tramp-replace-environment-variables - (apply 'tramp-file-name-for-operation operation args))) + (apply #'tramp-file-name-for-operation operation args))) (fn (assoc operation tramp-sh-file-name-handler-alist))) - (with-parsed-tramp-file-name filename nil - (cond - ;; That's what we want: file names, for which checks are - ;; applied. We assume that VC uses only `file-exists-p' and - ;; `file-readable-p' checks; otherwise we must extend the - ;; list. We do not perform any action, but return nil, in - ;; order to keep `vc-registered' running. - ((and fn (memq operation '(file-exists-p file-readable-p))) - (add-to-list 'tramp-vc-registered-file-names localname 'append) - nil) - ;; `process-file' and `start-file-process' shall be ignored. - ((and fn (eq operation 'process-file) 0)) - ((and fn (eq operation 'start-file-process) nil)) - ;; Tramp file name handlers like `expand-file-name'. They - ;; must still work. - (fn (save-match-data (apply (cdr fn) args))) - ;; Default file name handlers, we don't care. - (t (tramp-run-real-handler operation args))))))) + (if (tramp-tramp-file-p filename) + (with-parsed-tramp-file-name filename nil + (cond + ;; That's what we want: file names, for which checks are + ;; applied. We assume that VC uses only `file-exists-p' + ;; and `file-readable-p' checks; otherwise we must extend + ;; the list. We do not perform any action, but return + ;; nil, in order to keep `vc-registered' running. + ((and fn (memq operation '(file-exists-p file-readable-p))) + (add-to-list 'tramp-vc-registered-file-names localname 'append) + nil) + ;; `process-file' and `start-file-process' shall be ignored. + ((and fn (eq operation 'process-file) 0)) + ((and fn (eq operation 'start-file-process) nil)) + ;; Tramp file name handlers like `expand-file-name'. They + ;; must still work. + (fn (save-match-data (apply (cdr fn) args))) + ;; Default file name handlers, we don't care. + (t (tramp-run-real-handler operation args)))) + + ;; When `tramp-mode' is not enabled, or the file name is + ;; quoted, we don't do anything. + (tramp-run-real-handler operation args))))) (defun tramp-sh-handle-file-notify-add-watch (file-name flags _callback) "Like `file-notify-add-watch' for Tramp files." @@ -3574,29 +3575,19 @@ Fall back to normal file name handler if no Tramp handler exists." (let ((default-directory (file-name-directory file-name)) command events filter p sequence) (cond - ;; 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))) - ;; inotifywait. + ;; "inotifywait". ((setq command (tramp-get-remote-inotifywait v)) - (setq filter 'tramp-sh-inotifywait-process-filter + (setq filter #'tramp-sh-inotifywait-process-filter events (cond ((and (memq 'change flags) (memq 'attribute-change flags)) - (concat "create,modify,move,moved_from,moved_to,move_self," - "delete,delete_self,attrib,ignored")) + (eval-when-compile + (concat "create,modify,move,moved_from,moved_to,move_self," + "delete,delete_self,attrib,ignored"))) ((memq 'change flags) - (concat "create,modify,move,moved_from,moved_to,move_self," - "delete,delete_self,ignored")) + (eval-when-compile + (concat "create,modify,move,moved_from,moved_to,move_self," + "delete,delete_self,ignored"))) ((memq 'attribute-change flags) "attrib,ignored")) sequence `(,command "-mq" "-e" ,events ,localname) ;; Make events a list of symbols. @@ -3604,6 +3595,30 @@ Fall back to normal file name handler if no Tramp handler exists." (mapcar (lambda (x) (intern-soft (replace-regexp-in-string "_" "-" x))) (split-string events "," 'omit)))) + ;; "gio monitor". + ((setq command (tramp-get-remote-gio-monitor v)) + (setq filter #'tramp-sh-gio-monitor-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 "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 @@ -3611,7 +3626,7 @@ Fall back to normal file name handler if no Tramp handler exists." (file-remote-p file-name)))) ;; Start process. (setq p (apply - 'start-file-process + #'start-file-process (file-name-nondirectory command) (generate-new-buffer (format " *%s*" (file-name-nondirectory command))) @@ -3621,22 +3636,82 @@ Fall back to normal file name handler if no Tramp handler exists." (tramp-error v 'file-notify-error "`%s' failed to start on remote host" - (mapconcat 'identity sequence " ")) - (tramp-message v 6 "Run `%s', %S" (mapconcat 'identity sequence " ") p) - (tramp-set-connection-property p "vector" v) + (string-join sequence " ")) + (tramp-message v 6 "Run `%s', %S" (string-join sequence " ") p) + (process-put p 'vector v) ;; Needed for process filter. (process-put p 'events events) (process-put p 'watch-name localname) (set-process-query-on-exit-flag p nil) (set-process-filter p filter) + (set-process-sentinel p #'tramp-file-notify-process-sentinel) ;; There might be an error if the monitor is not supported. ;; Give the filter a chance to read the output. - (tramp-accept-process-output p 1) + (while (tramp-accept-process-output p 0)) (unless (process-live-p p) (tramp-error - v 'file-notify-error "Monitoring not supported for `%s'" file-name)) + p 'file-notify-error "Monitoring not supported for `%s'" file-name)) p)))) +(defun tramp-sh-gio-monitor-process-filter (proc string) + "Read output from \"gio monitor\" 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) + ;; Fix action names. + string (replace-regexp-in-string + "attributes changed" "attribute-changed" string) + string (replace-regexp-in-string + "changes done" "changes-done-hint" string) + string (replace-regexp-in-string + "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 (replace-regexp-in-string "\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)) + (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." @@ -3652,15 +3727,14 @@ file-notify events." ;; Attribute change is returned in unused wording. string (replace-regexp-in-string "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string)) - (when (string-match "Monitoring not supported" string) - (delete-process proc)) (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]+") + (eval-when-compile + (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)) @@ -3676,16 +3750,12 @@ file-notify events." (concat remote-prefix file) (when file1 (concat remote-prefix file1))))) (setq string (replace-match "" nil nil string)) - ;; Remove watch when file or directory to be watched is deleted. - (when (and (member (cl-caadr object) '(moved deleted)) - (string-equal file (process-get proc 'watch-name))) - (delete-process proc)) ;; 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 - 'file-notify-handle-event + (lookup-key special-event-map [file-notify]) `(file-notify ,object file-notify-callback))))) ;; Save rest of the string. @@ -3699,12 +3769,12 @@ file-notify events." (tramp-message proc 6 "%S\n%s" proc string) (dolist (line (split-string string "[\n\r]+" 'omit)) ;; Check, whether there is a problem. - (unless - (string-match - (concat "^[^[:blank:]]+" - "[[:blank:]]+\\([^[:blank:]]+\\)+" - "\\([[:blank:]]+\\([^\n\r]+\\)\\)?") - line) + (unless (string-match + (eval-when-compile + (concat "^[^[:blank:]]+" + "[[:blank:]]+\\([^[:blank:]]+\\)+" + "\\([[:blank:]]+\\([^\n\r]+\\)\\)?")) + line) (tramp-error proc 'file-notify-error "%s" line)) (let ((object @@ -3716,15 +3786,12 @@ file-notify events." (replace-regexp-in-string "_" "-" (downcase x)))) (split-string (match-string 1 line) "," 'omit)) (match-string 3 line)))) - ;; Remove watch when file or directory to be watched is deleted. - (when (member (cl-caadr object) '(move-self delete-self ignored)) - (delete-process proc)) ;; 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 - 'file-notify-handle-event + (lookup-key special-event-map [file-notify]) `(file-notify ,object file-notify-callback))))))) (defun tramp-sh-handle-file-system-info (filename) @@ -3735,21 +3802,26 @@ file-notify events." (tramp-message v 5 "file system info: %s" localname) (tramp-send-command v (format - "%s --block-size=1 --output=size,used,avail %s" + "%s %s" (tramp-get-remote-df v) (tramp-shell-quote-argument localname))) (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) (forward-line) (when (looking-at - (concat "[[:space:]]*\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)")) - (list (string-to-number (concat (match-string 1) "e0")) - ;; The second value is the used size. We need the - ;; free size. - (- (string-to-number (concat (match-string 1) "e0")) - (string-to-number (concat (match-string 2) "e0"))) - (string-to-number (concat (match-string 3) "e0"))))))))) + (eval-when-compile + (concat "\\(?:^/[^[:space:]]*[[:space:]]\\)?" + "[[:space:]]*\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)"))) + (mapcar + (lambda (d) + (* d (tramp-get-connection-property v "df-blocksize" 0))) + (list (string-to-number (match-string 1)) + ;; The second value is the used size. We need the + ;; free size. + (- (string-to-number (match-string 1)) + (string-to-number (match-string 2))) + (string-to-number (match-string 3)))))))))) ;;; Internal Functions: @@ -3768,7 +3840,7 @@ Only send the definition if it has not already been done." (setq script (replace-regexp-in-string (make-string 1 ?\t) (make-string 8 ? ) script)) ;; The script could contain a call of Perl. This is masked with `%s'. - (when (and (string-match "%s" script) + (when (and (string-match-p "%s" script) (not (tramp-get-remote-perl vec))) (tramp-error vec 'file-error "No Perl available on remote host")) (tramp-barf-unless-okay @@ -3829,12 +3901,12 @@ This function expects to be in the right *tramp* buffer." ;; 5.11") have problems with this command, we disable the call ;; therefore. (unless (or ignore-path - (string-match - (regexp-opt '("SunOS 5.10" "SunOS 5.11")) + (string-match-p + (eval-when-compile (regexp-opt '("SunOS 5.10" "SunOS 5.11"))) (tramp-get-connection-property vec "uname" ""))) (tramp-send-command vec (format "which \\%s | wc -w" progname)) (goto-char (point-min)) - (if (looking-at "^\\s-*1$") + (if (looking-at-p "^\\s-*1$") (setq result (concat "\\" progname)))) (unless result (when ignore-tilde @@ -3848,14 +3920,15 @@ This function expects to be in the right *tramp* buffer." (setq dirlist (nreverse newdl)))) (tramp-send-command vec - (format (concat "while read d; " - "do if test -x $d/%s && test -f $d/%s; " - "then echo tramp_executable $d/%s; " - "break; fi; done <<'%s'\n" - "%s\n%s") + (format (eval-when-compile + (concat "while read d; " + "do if test -x $d/%s && test -f $d/%s; " + "then echo tramp_executable $d/%s; " + "break; fi; done <<'%s'\n" + "%s\n%s")) progname progname progname tramp-end-of-heredoc - (mapconcat 'identity dirlist "\n") + (string-join dirlist "\n") tramp-end-of-heredoc)) (goto-char (point-max)) (when (search-backward "tramp_executable " nil t) @@ -3864,15 +3937,33 @@ This function expects to be in the right *tramp* buffer." (setq result (buffer-substring (point) (point-at-eol))))) result))) +;; On hydra.nixos.org, the $PATH environment variable is too long to +;; send it. This is likely not due to PATH_MAX, but PIPE_BUF. We +;; check it, and use a temporary file in case of. See Bug#33781. (defun tramp-set-remote-path (vec) "Sets the remote environment PATH to existing directories. I.e., for each directory in `tramp-remote-path', it is tested whether it exists and if so, it is added to the environment variable PATH." - (tramp-message vec 5 "Setting $PATH environment variable") - (tramp-send-command - vec (format "PATH=%s; export PATH" - (mapconcat 'identity (tramp-get-remote-path vec) ":")))) + (let ((command + (format + "PATH=%s; export PATH" (string-join (tramp-get-remote-path vec) ":"))) + (pipe-buf + (or (with-tramp-connection-property vec "pipe-buf" + (tramp-send-command-and-read + vec "getconf PIPE_BUF / 2>/dev/null || echo nil" 'noerror)) + 4096)) + tmpfile) + (tramp-message vec 5 "Setting $PATH environment variable") + (if (< (length command) pipe-buf) + (tramp-send-command vec command) + ;; Use a temporary file. + (setq tmpfile + (tramp-make-tramp-file-name vec (tramp-make-tramp-temp-file vec))) + (write-region command nil tmpfile) + (tramp-send-command + vec (format ". %s" (tramp-compat-file-local-name tmpfile))) + (delete-file tmpfile)))) ;; ------------------------------------------------------------ ;; -- Communication with external shell -- @@ -3941,7 +4032,7 @@ file exists and nonzero exit status otherwise." item extra-args) (while (and alist (null extra-args)) (setq item (pop alist)) - (when (string-match (car item) shell) + (when (string-match-p (car item) shell) (setq extra-args (cdr item)))) ;; It is useful to set the prompt in the following command ;; because some people have a setting for $PS1 which /bin/sh @@ -3962,9 +4053,10 @@ file exists and nonzero exit status otherwise." ;; initial probes to ensure the remote shell is usable.) (tramp-send-command vec (format - (concat - "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " - "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s") + (eval-when-compile + (concat + "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " + "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s")) tramp-terminal-type emacs-version tramp-version ; INSIDE_EMACS (or (getenv-internal "ENV" tramp-remote-process-environment) "") @@ -4002,13 +4094,14 @@ file exists and nonzero exit status otherwise." ;; CCC: "root" does not exist always, see my QNAP TS-459. ;; Which check could we apply instead? (tramp-send-command vec "echo ~root" t) - (if (or (string-match "^~root$" (buffer-string)) + (if (or (string-match-p "^~root$" (buffer-string)) ;; The default shell (ksh93) of OpenSolaris and ;; Solaris is buggy. We've got reports for ;; "SunOS 5.10" and "SunOS 5.11" so far. - (string-match (regexp-opt '("SunOS 5.10" "SunOS 5.11")) - (tramp-get-connection-property - vec "uname" ""))) + (string-match-p + (eval-when-compile + (regexp-opt '("SunOS 5.10" "SunOS 5.11"))) + (tramp-get-connection-property vec "uname" ""))) (or (tramp-find-executable vec "bash" (tramp-get-remote-path vec) t t) @@ -4019,9 +4112,10 @@ file exists and nonzero exit status otherwise." default-shell (tramp-message vec 2 - (concat - "Couldn't find a remote shell which groks tilde " - "expansion, using `%s'") + (eval-when-compile + (concat + "Couldn't find a remote shell which groks tilde " + "expansion, using `%s'")) default-shell))) default-shell))) @@ -4038,7 +4132,7 @@ file exists and nonzero exit status otherwise." "Wait for shell prompt and barf if none appears. Looks at process PROC to see if a shell prompt appears in TIMEOUT seconds. If not, it produces an error message with the given ERROR-ARGS." - (let ((vec (tramp-get-connection-property proc "vector" nil))) + (let ((vec (process-get proc 'vector))) (condition-case nil (tramp-wait-for-regexp proc timeout @@ -4046,7 +4140,7 @@ seconds. If not, it produces an error message with the given ERROR-ARGS." "\\(%s\\|%s\\)\\'" shell-prompt-pattern tramp-shell-prompt-pattern)) (error (delete-process proc) - (apply 'tramp-error-with-buffer + (apply #'tramp-error-with-buffer (tramp-get-connection-buffer vec) vec 'file-error error-args))))) (defun tramp-open-connection-setup-interactive-shell (proc vec) @@ -4067,7 +4161,7 @@ process to set up. VEC specifies the connection." (tramp-send-command vec "echo foo" t) (with-current-buffer (process-buffer proc) (goto-char (point-min)) - (when (looking-at "echo foo") + (when (looking-at-p "echo foo") (tramp-set-connection-property proc "remote-echo" t) (tramp-message vec 5 "Remote echo still on. Ok.") ;; Make sure backspaces and their echo are enabled and no line @@ -4106,10 +4200,10 @@ 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 "^Darwin" uname) + (string-match-p "^Darwin" uname) (cons 'utf-8-hfs 'utf-8-hfs)) (and (memq 'utf-8 (coding-system-list)) - (string-match "utf-?8" (tramp-get-remote-locale vec)) + (string-match-p "utf-?8" (tramp-get-remote-locale vec)) (cons 'utf-8 'utf-8)) (process-coding-system proc) (cons 'undecided 'undecided))) @@ -4119,7 +4213,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 "^Darwin" uname) 'mac 'unix))) + cs-encode (if (string-match-p "^Darwin" uname) 'mac 'unix))) (tramp-send-command vec "(echo foo ; echo bar)" t) (goto-char (point-min)) (when (search-forward "\r" nil t) @@ -4143,7 +4237,7 @@ process to set up. VEC specifies the connection." (t (tramp-message vec 5 "Checking remote host type for `send-process-string' bug") - (if (string-match "^FreeBSD" uname) 500 0)))) + (if (string-match-p "^FreeBSD" uname) 500 0)))) ;; Set remote PATH variable. (tramp-set-remote-path vec) @@ -4166,11 +4260,11 @@ 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 ;; <http://stackoverflow.com/questions/3291692/irix-bash-shell-expands-expression-in-single-quotes-yet-shouldnt>. - (when (string-match "^IRIX64" uname) + (when (string-match-p "^IRIX64" uname) (tramp-send-command vec "set +H" t)) ;; Disable tab expansion. - (if (string-match "BSD\\|Darwin" uname) + (if (string-match-p "BSD\\|Darwin" uname) (tramp-send-command vec "stty tabs" t) (tramp-send-command vec "stty tab0" t)) @@ -4196,7 +4290,7 @@ process to set up. VEC specifies the connection." (append `(,(tramp-get-remote-locale vec)) (copy-sequence tramp-remote-process-environment)))) (setq item (split-string item "=" 'omit)) - (setcdr item (mapconcat 'identity (cdr item) "=")) + (setcdr item (string-join (cdr item) "=")) (if (and (stringp (cdr item)) (not (string-equal (cdr item) ""))) (push (format "%s %s" (car item) (cdr item)) vars) (push (car item) unset))) @@ -4206,12 +4300,12 @@ process to set up. VEC specifies the connection." (format "while read var val; do export $var=\"$val\"; done <<'%s'\n%s\n%s" tramp-end-of-heredoc - (mapconcat 'identity vars "\n") + (string-join vars "\n") tramp-end-of-heredoc) t)) (when unset (tramp-send-command - vec (format "unset %s" (mapconcat 'identity unset " ")) t))))) + vec (format "unset %s" (string-join unset " ")) t))))) ;; Old text from documentation of tramp-methods: ;; Using a uuencode/uudecode inline method is discouraged, please use one @@ -4237,7 +4331,7 @@ Each item is a list that looks like this: \(FORMAT ENCODING DECODING) -FORMAT is symbol describing the encoding/decoding format. It can be +FORMAT is a symbol describing the encoding/decoding format. It can be `b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing. ENCODING and DECODING can be strings, giving commands, or symbols, @@ -4317,16 +4411,14 @@ Goes through the list `tramp-local-coding-commands' and vec 5 "Checking local encoding function `%s'" loc-enc) (tramp-message vec 5 "Checking local encoding command `%s' for sanity" loc-enc) - (unless (zerop (tramp-call-local-coding-command - loc-enc nil nil)) + (unless (zerop (tramp-call-local-coding-command loc-enc nil nil)) (throw 'wont-work-local nil))) (if (not (stringp loc-dec)) (tramp-message vec 5 "Checking local decoding function `%s'" loc-dec) (tramp-message vec 5 "Checking local decoding command `%s' for sanity" loc-dec) - (unless (zerop (tramp-call-local-coding-command - loc-dec nil nil)) + (unless (zerop (tramp-call-local-coding-command loc-dec nil nil)) (throw 'wont-work-local nil))) ;; Search for remote coding commands with the same format (while (and remote-commands (not found)) @@ -4344,7 +4436,7 @@ Goes through the list `tramp-local-coding-commands' and (throw 'wont-work-remote nil))) ;; Check if remote perl exists when necessary. (when (and (symbolp rem-enc) - (string-match "perl" (symbol-name rem-enc)) + (string-match-p "perl" (symbol-name rem-enc)) (not (tramp-get-remote-perl vec))) (throw 'wont-work-remote nil)) ;; Check if remote encoding and decoding commands can be @@ -4355,9 +4447,9 @@ Goes through the list `tramp-local-coding-commands' and ;; actually check the output it gives. And also, when ;; redirecting "mimencode" output to /dev/null, then as root ;; it might change the permissions of /dev/null! - (when (not (stringp rem-enc)) + (unless (stringp rem-enc) (let ((name (symbol-name rem-enc))) - (while (string-match (regexp-quote "-") name) + (while (string-match "-" name) (setq name (replace-match "_" nil t name))) (tramp-maybe-send-script vec (symbol-value rem-enc) name) (setq rem-enc name))) @@ -4368,13 +4460,13 @@ Goes through the list `tramp-local-coding-commands' and vec (format "%s </dev/null" rem-enc) t) (throw 'wont-work-remote nil)) - (when (not (stringp rem-dec)) + (unless (stringp rem-dec) (let ((name (symbol-name rem-dec)) (value (symbol-value rem-dec)) tmpfile) - (while (string-match (regexp-quote "-") name) + (while (string-match "-" name) (setq name (replace-match "_" nil t name))) - (when (string-match "\\(^\\|[^%]\\)%t" value) + (when (string-match-p "\\(^\\|[^%]\\)%t" value) (setq tmpfile (make-temp-name (expand-file-name @@ -4384,8 +4476,7 @@ Goes through the list `tramp-local-coding-commands' and (format-spec value (format-spec-make - ?t - (file-remote-p tmpfile 'localname))))) + ?t (tramp-compat-file-local-name tmpfile))))) (tramp-maybe-send-script vec value name) (setq rem-dec name))) (tramp-message @@ -4397,9 +4488,9 @@ Goes through the list `tramp-local-coding-commands' and t) (throw 'wont-work-remote nil)) - (with-current-buffer (tramp-get-buffer vec) + (with-current-buffer (tramp-get-connection-buffer vec) (goto-char (point-min)) - (unless (looking-at (regexp-quote magic)) + (unless (looking-at-p (regexp-quote magic)) (throw 'wont-work-remote nil))) ;; `rem-enc' and `rem-dec' could be a string meanwhile. @@ -4429,12 +4520,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 "%s" cmd))) input) + (when (and input (not (string-match-p "%s" cmd))) input) (if (eq output t) t nil) nil tramp-encoding-command-switch (concat - (if (string-match "%s" cmd) (format cmd input) cmd) + (if (string-match-p "%s" cmd) (format cmd input) cmd) (if (stringp output) (concat " >" output) "")))) (defconst tramp-inline-compress-commands @@ -4442,6 +4533,7 @@ means discard it)." ("env GZIP= gzip" "env GZIP= gzip -d") ("bzip2" "bzip2 -d") ("xz" "xz -d") + ("zstd --rm" "zstd -d --rm") ("compress" "compress -d")) "List of compress and decompress commands for inline transfer. Each item is a list that looks like this: @@ -4467,27 +4559,36 @@ Goes through the list `tramp-inline-compress-commands'." vec 5 "Checking local compress commands `%s', `%s' for sanity" compress decompress) - (unless - (zerop - (tramp-call-local-coding-command - (format - "echo %s | %s | %s" magic - ;; Windows shells need the program file name after - ;; the pipe symbol be quoted if they use forward - ;; slashes as directory separators. - (mapconcat - 'shell-quote-argument (split-string compress) " ") - (mapconcat - 'shell-quote-argument (split-string decompress) " ")) - nil nil)) - (throw 'next nil)) - (tramp-message + (with-temp-buffer + (unless (zerop + (tramp-call-local-coding-command + (format + "echo %s | %s | %s" magic + ;; Windows shells need the program file name + ;; after the pipe symbol be quoted if they use + ;; forward slashes as directory separators. + (mapconcat + #'tramp-unquote-shell-quote-argument + (split-string compress) " ") + (mapconcat + #'tramp-unquote-shell-quote-argument + (split-string decompress) " ")) + nil t)) + (throw 'next nil)) + (goto-char (point-min)) + (unless (looking-at-p (regexp-quote magic)) + (throw 'next nil))) + (tramp-message vec 5 "Checking remote compress commands `%s', `%s' for sanity" compress decompress) (unless (tramp-send-command-and-check vec (format "echo %s | %s | %s" magic compress decompress) t) (throw 'next nil)) + (with-current-buffer (tramp-get-buffer vec) + (goto-char (point-min)) + (unless (looking-at-p (regexp-quote magic)) + (throw 'next nil))) (setq found t))) ;; Did we find something? @@ -4510,28 +4611,27 @@ Goes through the list `tramp-inline-compress-commands'." (defun tramp-compute-multi-hops (vec) "Expands VEC according to `tramp-default-proxies-alist'." - (let ((target-alist `(,vec)) + (let ((saved-tdpa tramp-default-proxies-alist) + (target-alist `(,vec)) (hops (or (tramp-file-name-hop vec) "")) (item vec) choices proxy) ;; Ad-hoc proxy definitions. (dolist (proxy (reverse (split-string hops tramp-postfix-hop-regexp 'omit))) - (let ((user (tramp-file-name-user item)) - (host (tramp-file-name-host item)) - (proxy (concat - tramp-prefix-format proxy tramp-postfix-host-format))) - (tramp-message - vec 5 "Add proxy (\"%s\" \"%s\" \"%s\")" - (and (stringp host) (regexp-quote host)) - (and (stringp user) (regexp-quote user)) - proxy) + (let* ((host-port (tramp-file-name-host-port item)) + (user-domain (tramp-file-name-user-domain item)) + (proxy (concat + tramp-prefix-format proxy tramp-postfix-host-format)) + (entry + (list (and (stringp host-port) + (concat "^" (regexp-quote host-port) "$")) + (and (stringp user-domain) + (concat "^" (regexp-quote user-domain) "$")) + (propertize proxy 'tramp-ad-hoc t)))) + (tramp-message vec 5 "Add %S to `tramp-default-proxies-alist'" entry) ;; Add the hop. - (add-to-list - 'tramp-default-proxies-alist - (list (and (stringp host) (regexp-quote host)) - (and (stringp user) (regexp-quote user)) - proxy)) + (add-to-list 'tramp-default-proxies-alist entry) (setq item (tramp-dissect-file-name proxy)))) ;; Save the new value. (when (and hops tramp-save-ad-hoc-proxies) @@ -4545,11 +4645,15 @@ Goes through the list `tramp-inline-compress-commands'." proxy (eval (nth 2 item))) (when (and ;; Host. - (string-match (or (eval (nth 0 item)) "") - (or (tramp-file-name-host (car target-alist)) "")) + (string-match-p + (or (eval (nth 0 item)) "") + (or (tramp-file-name-host-port (car target-alist)) + "")) ;; User. - (string-match (or (eval (nth 1 item)) "") - (or (tramp-file-name-user (car target-alist)) ""))) + (string-match-p + (or (eval (nth 1 item)) "") + (or (tramp-file-name-user-domain (car target-alist)) + ""))) (if (null proxy) ;; No more hops needed. (setq choices nil) @@ -4572,30 +4676,30 @@ Goes through the list `tramp-inline-compress-commands'." (while (setq item (pop choices)) (when (or (not (tramp-get-method-parameter item 'tramp-login-program)) (tramp-get-method-parameter item 'tramp-copy-program)) - (tramp-error - vec 'file-error - "Method `%s' is not supported for multi-hops." + (setq tramp-default-proxies-alist saved-tdpa) + (tramp-user-error + vec "Method `%s' is not supported for multi-hops." (tramp-file-name-method item))))) - ;; In case the host name is not used for the remote shell - ;; command, the user could be misguided by applying a random - ;; host name. - (let* ((v (car target-alist)) - (method (tramp-file-name-method v)) - (host (tramp-file-name-host v))) - (unless - (or - ;; There are multi-hops. - (cdr target-alist) - ;; The host name is used for the remote shell command. - (member '("%h") (tramp-get-method-parameter v 'tramp-login-args)) - ;; The host is local. We cannot use `tramp-local-host-p' - ;; here, because it opens a connection as well. - (string-match tramp-local-host-regexp host)) - (tramp-error - v 'file-error - "Host `%s' looks like a remote host, `%s' can only use the local host" - host method))) + ;; Some methods ("su", "sg", "sudo", "doas", "ksu") do not use the + ;; host name in their command template. In this case, the remote + ;; file name must use either a local host name (first hop), or a + ;; host name matching the previous hop. + (let ((previous-host (or tramp-local-host-regexp ""))) + (setq choices target-alist) + (while (setq item (pop choices)) + (let ((host (tramp-file-name-host item))) + (unless + (or + ;; The host name is used for the remote shell command. + (member + '("%h") (tramp-get-method-parameter item 'tramp-login-args)) + ;; The host name must match previous hop. + (string-match-p previous-host host)) + (setq tramp-default-proxies-alist saved-tdpa) + (tramp-user-error + vec "Host name `%s' does not match `%s'" host previous-host)) + (setq previous-host (concat "^" (regexp-quote host) "$"))))) ;; Result. target-alist)) @@ -4617,7 +4721,7 @@ Goes through the list `tramp-inline-compress-commands'." (ignore-errors (when (executable-find "ssh") (with-tramp-progress-reporter - vec 4 "Computing ControlMaster options" + vec 4 "Computing ControlMaster options" (with-temp-buffer (tramp-call-process vec "ssh" nil t nil "-o" "ControlMaster") (goto-char (point-min)) @@ -4647,6 +4751,19 @@ Goes through the list `tramp-inline-compress-commands'." " -o ControlPersist=no"))))))))) tramp-ssh-controlmaster-options))) +(defun tramp-timeout-session (vec) + "Close the connection VEC after a session timeout. +If there is just some editing, retry it after 5 seconds." + (if (and tramp-locked tramp-locker + (tramp-file-name-equal-p vec (car tramp-current-connection))) + (progn + (tramp-message + vec 5 "Cannot timeout session, trying it again in %s seconds." 5) + (run-at-time 5 nil 'tramp-timeout-session vec)) + (tramp-message + vec 3 "Timeout session %s" (tramp-make-tramp-file-name vec 'localname)) + (tramp-cleanup-connection vec 'keep-debug))) + (defun tramp-maybe-open-connection (vec) "Maybe open a connection VEC. Does not do anything if a connection is already open, but re-opens the @@ -4661,9 +4778,12 @@ connection if a previous connection has died for some reason." (unless (or (process-live-p p) (not (tramp-file-name-equal-p vec (car tramp-current-connection))) - (> (tramp-time-diff - (current-time) (cdr tramp-current-connection)) - (or tramp-connection-min-time-diff 0))) + (time-less-p + ;; `current-time' can be removed once we get rid of Emacs 24. + (time-since (or (cdr tramp-current-connection) (current-time))) + ;; `seconds-to-time' can be removed once we get rid + ;; of Emacs 24. + (seconds-to-time (or tramp-connection-min-time-diff 0)))) (throw 'suppress 'suppress)) ;; If too much time has passed since last command was sent, look @@ -4674,11 +4794,11 @@ connection if a previous connection has died for some reason." ;; try to send a command from time to time, then look again ;; whether the process is really alive. (condition-case nil - (when (and (> (tramp-time-diff - (current-time) - (tramp-get-connection-property - p "last-cmd-time" '(0 0 0))) - 60) + ;; `seconds-to-time' can be removed once we get rid of Emacs 24. + (when (and (time-less-p (seconds-to-time 60) + (time-since + (tramp-get-connection-property + p "last-cmd-time" (seconds-to-time 0)))) (process-live-p p)) (tramp-send-command vec "echo are you awake" t t) (unless (and (process-live-p p) @@ -4729,7 +4849,8 @@ connection if a previous connection has died for some reason." (setenv "PS1" tramp-initial-end-of-output) (unless (stringp tramp-encoding-shell) (tramp-error vec 'file-error "`tramp-encoding-shell' not set")) - (let* ((target-alist (tramp-compute-multi-hops vec)) + (let* ((current-host (system-name)) + (target-alist (tramp-compute-multi-hops vec)) ;; We will apply `tramp-ssh-controlmaster-options' ;; only for the first hop. (options (tramp-ssh-controlmaster-options vec)) @@ -4744,7 +4865,7 @@ connection if a previous connection has died for some reason." (p (let ((default-directory (tramp-compat-temporary-file-directory))) (apply - 'start-process + #'start-process (tramp-get-connection-name vec) (tramp-get-connection-buffer vec) (if tramp-encoding-command-interactive @@ -4752,16 +4873,14 @@ connection if a previous connection has died for some reason." tramp-encoding-command-interactive) (list tramp-encoding-shell)))))) - ;; Set sentinel and query flag. - (tramp-set-connection-property p "vector" vec) - (set-process-sentinel p 'tramp-process-sentinel) - (process-put p 'adjust-window-size-function 'ignore) + ;; Set sentinel and query flag. Initialize variables. + (set-process-sentinel p #'tramp-process-sentinel) + (process-put p 'vector vec) + (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) - (setq tramp-current-connection (cons vec (current-time)) - tramp-current-host (system-name)) + (setq tramp-current-connection (cons vec (current-time))) - (tramp-message - vec 6 "%s" (mapconcat 'identity (process-command p) " ")) + (tramp-message vec 6 "%s" (string-join (process-command p) " ")) ;; Check whether process is alive. (tramp-barf-if-no-shell-prompt @@ -4812,16 +4931,24 @@ connection if a previous connection has died for some reason." ;; Check, whether there is a restricted shell. (dolist (elt tramp-restricted-shell-hosts-alist) - (when (string-match elt tramp-current-host) + (when (string-match-p elt current-host) (setq r-shell t))) - - ;; Set variables for computing the prompt for - ;; reading password. - (setq tramp-current-method l-method - tramp-current-user l-user - tramp-current-domain l-domain - tramp-current-host l-host - tramp-current-port l-port) + (setq current-host l-host) + + ;; Set password prompt vector. + (tramp-set-connection-property + p "password-vector" + (make-tramp-file-name + :method l-method :user l-user :domain l-domain + :host l-host :port l-port)) + + ;; Set session timeout. + (when (tramp-get-method-parameter + hop 'tramp-session-timeout) + (tramp-set-connection-property + p "session-timeout" + (tramp-get-method-parameter + hop 'tramp-session-timeout))) ;; Add login environment. (when login-env @@ -4830,7 +4957,7 @@ connection if a previous connection has died for some reason." (mapcar (lambda (x) (setq x (mapcar (lambda (y) (format-spec y spec)) x)) - (unless (member "" x) (mapconcat 'identity x " "))) + (unless (member "" x) (string-join x " "))) login-env)) (while login-env (setq command @@ -4859,7 +4986,7 @@ connection if a previous connection has died for some reason." (mapconcat (lambda (x) (setq x (mapcar (lambda (y) (format-spec y spec)) x)) - (unless (member "" x) (mapconcat 'identity 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 @@ -4886,6 +5013,12 @@ connection if a previous connection has died for some reason." ;; Set connection-local variables. (tramp-set-connection-local-variables vec) + ;; Activate session timeout. + (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)) + ;; Make initial shell settings. (tramp-open-connection-setup-interactive-shell p vec) @@ -4914,7 +5047,7 @@ function waits for output unless NOOUTPUT is set." ;; `tramp-echo-mark', so the remote shell sees two consecutive ;; trailing line endings and sends two prompts after executing ;; the command, which confuses `tramp-wait-for-output'. - (when (and (not (string= command "")) + (when (and (not (string-empty-p command)) (string-equal (substring command -1) "\n")) (setq command (substring command 0 -1))) ;; No need to restore a trailing newline here since `tramp-send-string' @@ -4945,7 +5078,7 @@ function waits for output unless NOOUTPUT is set." (regexp1 (format "\\(^\\|\000\\)%s" regexp)) (found (tramp-wait-for-regexp proc timeout regexp1))) (if found - (let (buffer-read-only) + (let ((inhibit-read-only t)) ;; A simple-minded busybox has sent " ^H" sequences. ;; Delete them. (goto-char (point-min)) @@ -4992,7 +5125,7 @@ DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null." (skip-chars-forward "^ ") (prog1 (zerop (read (current-buffer))) - (let (buffer-read-only) + (let ((inhibit-read-only t)) (delete-region (match-beginning 0) (point-max)))))) (defun tramp-barf-unless-okay (vec command fmt &rest args) @@ -5000,7 +5133,7 @@ DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null." Similar to `tramp-send-command-and-check' but accepts two more arguments FMT and ARGS which are passed to `error'." (or (tramp-send-command-and-check vec command) - (apply 'tramp-error vec 'file-error fmt args))) + (apply #'tramp-error vec 'file-error fmt args))) (defun tramp-send-command-and-read (vec command &optional noerror marker) "Run COMMAND and return the output, which must be a Lisp expression. @@ -5008,7 +5141,7 @@ If MARKER is a regexp, read the output after that string. In case there is no valid Lisp expression and NOERROR is nil, it raises an error." (when (if noerror - (tramp-send-command-and-check vec command) + (ignore-errors (tramp-send-command-and-check vec command)) (tramp-barf-unless-okay vec command "`%s' returns with error" command)) (with-current-buffer (tramp-get-connection-buffer vec) @@ -5034,92 +5167,92 @@ raises an error." "`%s' does not return a valid Lisp expression: `%s'" command (buffer-string)))))))) +;; FIXME: Move to tramp.el? +;;;###tramp-autoload (defun tramp-convert-file-attributes (vec attr) "Convert `file-attributes' ATTR generated by perl script, stat or ls. Convert file mode bits to string and set virtual device number. Return ATTR." (when attr - ;; Remove color escape sequences from symlink. - (when (stringp (car attr)) - (while (string-match tramp-display-escape-sequence-regexp (car attr)) - (setcar attr (replace-match "" nil nil (car attr))))) - ;; Convert uid and gid. Use `tramp-unknown-id-integer' as - ;; indication of unusable value. - (when (and (numberp (nth 2 attr)) (< (nth 2 attr) 0)) - (setcar (nthcdr 2 attr) tramp-unknown-id-integer)) - (when (and (floatp (nth 2 attr)) - (<= (nth 2 attr) most-positive-fixnum)) - (setcar (nthcdr 2 attr) (round (nth 2 attr)))) - (when (and (numberp (nth 3 attr)) (< (nth 3 attr) 0)) - (setcar (nthcdr 3 attr) tramp-unknown-id-integer)) - (when (and (floatp (nth 3 attr)) - (<= (nth 3 attr) most-positive-fixnum)) - (setcar (nthcdr 3 attr) (round (nth 3 attr)))) - ;; Convert last access time. - (unless (listp (nth 4 attr)) - (setcar (nthcdr 4 attr) - (list (floor (nth 4 attr) 65536) - (floor (mod (nth 4 attr) 65536))))) - ;; Convert last modification time. - (unless (listp (nth 5 attr)) - (setcar (nthcdr 5 attr) - (list (floor (nth 5 attr) 65536) - (floor (mod (nth 5 attr) 65536))))) - ;; Convert last status change time. - (unless (listp (nth 6 attr)) - (setcar (nthcdr 6 attr) - (list (floor (nth 6 attr) 65536) - (floor (mod (nth 6 attr) 65536))))) - ;; Convert file size. - (when (< (nth 7 attr) 0) - (setcar (nthcdr 7 attr) -1)) - (when (and (floatp (nth 7 attr)) - (<= (nth 7 attr) most-positive-fixnum)) - (setcar (nthcdr 7 attr) (round (nth 7 attr)))) - ;; Convert file mode bits to string. - (unless (stringp (nth 8 attr)) - (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr))) + (save-match-data + ;; Remove color escape sequences from symlink. (when (stringp (car attr)) - (aset (nth 8 attr) 0 ?l))) - ;; Convert directory indication bit. - (when (string-match "^d" (nth 8 attr)) - (setcar attr t)) - ;; Convert symlink from `tramp-do-file-attributes-with-stat'. - (when (consp (car attr)) - (if (and (stringp (caar attr)) - (string-match ".+ -> .\\(.+\\)." (caar attr))) - (setcar attr (match-string 1 (caar attr))) - (setcar attr nil))) - ;; Set file's gid change bit. - (setcar (nthcdr 9 attr) - (if (numberp (nth 3 attr)) - (not (= (nth 3 attr) - (tramp-get-remote-gid vec 'integer))) - (not (string-equal - (nth 3 attr) - (tramp-get-remote-gid vec 'string))))) - ;; Convert inode. - (unless (listp (nth 10 attr)) - (setcar (nthcdr 10 attr) - (condition-case nil - (let ((high (nth 10 attr)) - middle low) - (if (<= high most-positive-fixnum) - (floor high) - ;; The low 16 bits. - (setq low (mod high #x10000) - high (/ high #x10000)) + (while (string-match tramp-display-escape-sequence-regexp (car attr)) + (setcar attr (replace-match "" nil nil (car attr))))) + ;; Convert uid and gid. Use `tramp-unknown-id-integer' as + ;; indication of unusable value. + (when (and (numberp (nth 2 attr)) (< (nth 2 attr) 0)) + (setcar (nthcdr 2 attr) tramp-unknown-id-integer)) + (when (and (floatp (nth 2 attr)) + (<= (nth 2 attr) most-positive-fixnum)) + (setcar (nthcdr 2 attr) (round (nth 2 attr)))) + (when (and (numberp (nth 3 attr)) (< (nth 3 attr) 0)) + (setcar (nthcdr 3 attr) tramp-unknown-id-integer)) + (when (and (floatp (nth 3 attr)) + (<= (nth 3 attr) most-positive-fixnum)) + (setcar (nthcdr 3 attr) (round (nth 3 attr)))) + ;; Convert last access time. + (unless (listp (nth 4 attr)) + (setcar (nthcdr 4 attr) (seconds-to-time (nth 4 attr)))) + ;; Convert last modification time. + (unless (listp (nth 5 attr)) + (setcar (nthcdr 5 attr) (seconds-to-time (nth 5 attr)))) + ;; Convert last status change time. + (unless (listp (nth 6 attr)) + (setcar (nthcdr 6 attr) (seconds-to-time (nth 6 attr)))) + ;; Convert file size. + (when (< (nth 7 attr) 0) + (setcar (nthcdr 7 attr) -1)) + (when (and (floatp (nth 7 attr)) + (<= (nth 7 attr) most-positive-fixnum)) + (setcar (nthcdr 7 attr) (round (nth 7 attr)))) + ;; Convert file mode bits to string. + (unless (stringp (nth 8 attr)) + (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr))) + (when (stringp (car attr)) + (aset (nth 8 attr) 0 ?l))) + ;; Convert directory indication bit. + (when (string-match-p "^d" (nth 8 attr)) + (setcar attr t)) + ;; Convert symlink from `tramp-do-file-attributes-with-stat'. + ;; Decode also multibyte string. + (when (consp (car attr)) + (setcar attr + (and (stringp (caar attr)) + (string-match ".+ -> .\\(.+\\)." (caar attr)) + (decode-coding-string + (match-string 1 (caar attr)) 'utf-8)))) + ;; Set file's gid change bit. + (setcar (nthcdr 9 attr) + (if (numberp (nth 3 attr)) + (not (= (nth 3 attr) + (tramp-get-remote-gid vec 'integer))) + (not (string-equal + (nth 3 attr) + (tramp-get-remote-gid vec 'string))))) + ;; Convert inode. + (when (floatp (nth 10 attr)) + (setcar (nthcdr 10 attr) + (condition-case nil + (let ((high (nth 10 attr)) + middle low) (if (<= high most-positive-fixnum) - (cons (floor high) (floor low)) - ;; The middle 24 bits. - (setq middle (mod high #x1000000) - high (/ high #x1000000)) - (cons (floor high) (cons (floor middle) (floor low)))))) - ;; Inodes can be incredible huge. We must hide this. - (error (tramp-get-inode vec))))) - ;; Set virtual device number. - (setcar (nthcdr 11 attr) - (tramp-get-device vec)) + (floor high) + ;; The low 16 bits. + (setq low (mod high #x10000) + high (/ high #x10000)) + (if (<= high most-positive-fixnum) + (cons (floor high) (floor low)) + ;; The middle 24 bits. + (setq middle (mod high #x1000000) + high (/ high #x1000000)) + (cons (floor high) + (cons (floor middle) (floor low)))))) + ;; Inodes can be incredible huge. We must hide this. + (error (tramp-get-inode vec))))) + ;; Set virtual device number. + (setcar (nthcdr 11 attr) + (tramp-get-device vec))) attr)) (defun tramp-shell-case-fold (string) @@ -5139,16 +5272,17 @@ Return ATTR." (host (tramp-file-name-host vec)) (localname (directory-file-name (tramp-file-name-unquote-localname vec)))) - (when (string-match tramp-ipv6-regexp host) + (when (string-match-p tramp-ipv6-regexp host) (setq host (format "[%s]" host))) - (unless (string-match "ftp$" method) + (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 (shell-quote-argument localname))) - (t (format "%s:%s" host (shell-quote-argument localname)))))) + (format + "%s@%s:%s" user host (tramp-unquote-shell-quote-argument localname))) + (t (format "%s:%s" host (tramp-unquote-shell-quote-argument localname)))))) (defun tramp-method-out-of-band-p (vec size) "Return t if this is an out-of-band method, nil otherwise." @@ -5168,94 +5302,90 @@ Return ATTR." (defun tramp-get-remote-path (vec) "Compile list of remote directories for $PATH. Nonexistent directories are removed from spec." - (with-tramp-connection-property - ;; When `tramp-own-remote-path' is in `tramp-remote-path', we - ;; cache the result for the session only. Otherwise, the result - ;; is cached persistently. - (if (memq 'tramp-own-remote-path tramp-remote-path) - (tramp-get-connection-process vec) - vec) - "remote-path" - (let* ((remote-path (copy-tree tramp-remote-path)) - (elt1 (memq 'tramp-default-remote-path remote-path)) - (elt2 (memq 'tramp-own-remote-path remote-path)) - (default-remote-path - (when elt1 - (or - (tramp-send-command-and-read - vec "echo \\\"`getconf PATH 2>/dev/null`\\\"" 'noerror) - ;; Default if "getconf" is not available. - (progn - (tramp-message - vec 3 - "`getconf PATH' not successful, using default value \"%s\"." - "/bin:/usr/bin") - "/bin:/usr/bin")))) - (own-remote-path - ;; The login shell could return more than just the $PATH - ;; string. So we use `tramp-end-of-heredoc' as marker. - (when elt2 - (or - (tramp-send-command-and-read - vec - (format - "%s %s %s 'echo %s \\\"$PATH\\\"'" - (tramp-get-method-parameter vec 'tramp-remote-shell) - (mapconcat - 'identity - (tramp-get-method-parameter vec 'tramp-remote-shell-login) - " ") - (mapconcat - 'identity - (tramp-get-method-parameter vec 'tramp-remote-shell-args) - " ") - (tramp-shell-quote-argument tramp-end-of-heredoc)) - 'noerror (regexp-quote tramp-end-of-heredoc)) - (progn - (tramp-message - vec 2 "Could not retrieve `tramp-own-remote-path'") - nil))))) - - ;; Replace place holder `tramp-default-remote-path'. - (when elt1 - (setcdr elt1 - (append - (split-string (or default-remote-path "") ":" 'omit) - (cdr elt1))) - (setq remote-path (delq 'tramp-default-remote-path remote-path))) - - ;; Replace place holder `tramp-own-remote-path'. - (when elt2 - (setcdr elt2 - (append - (split-string (or own-remote-path "") ":" 'omit) - (cdr elt2))) - (setq remote-path (delq 'tramp-own-remote-path remote-path))) - - ;; Remove double entries. - (setq elt1 remote-path) - (while (consp elt1) - (while (and (car elt1) (setq elt2 (member (car elt1) (cdr elt1)))) - (setcar elt2 nil)) - (setq elt1 (cdr elt1))) - - ;; Remove non-existing directories. - (delq - nil - (mapcar - (lambda (x) - (and - (stringp x) - (file-directory-p - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) + (with-current-buffer (tramp-get-connection-buffer vec) + ;; Expand connection-local variables. + (tramp-set-connection-local-variables vec) + (with-tramp-connection-property + ;; When `tramp-own-remote-path' is in `tramp-remote-path', we + ;; cache the result for the session only. Otherwise, the + ;; result is cached persistently. + (if (memq 'tramp-own-remote-path tramp-remote-path) + (tramp-get-connection-process vec) + vec) + "remote-path" + (let* ((remote-path (copy-tree tramp-remote-path)) + (elt1 (memq 'tramp-default-remote-path remote-path)) + (elt2 (memq 'tramp-own-remote-path remote-path)) + (default-remote-path + (when elt1 + (or + (tramp-send-command-and-read + vec "echo \\\"`getconf PATH 2>/dev/null`\\\"" 'noerror) + ;; Default if "getconf" is not available. + (progn + (tramp-message + vec 3 + "`getconf PATH' not successful, using default value \"%s\"." + "/bin:/usr/bin") + "/bin:/usr/bin")))) + (own-remote-path + ;; The login shell could return more than just the $PATH + ;; string. So we use `tramp-end-of-heredoc' as marker. + (when elt2 + (or + (tramp-send-command-and-read + vec + (format + "%s %s %s 'echo %s \\\"$PATH\\\"'" + (tramp-get-method-parameter vec 'tramp-remote-shell) + (mapconcat + #'identity + (tramp-get-method-parameter vec 'tramp-remote-shell-login) + " ") + (mapconcat + #'identity + (tramp-get-method-parameter vec 'tramp-remote-shell-args) + " ") + (tramp-shell-quote-argument tramp-end-of-heredoc)) + 'noerror (regexp-quote tramp-end-of-heredoc)) + (progn + (tramp-message + vec 2 "Could not retrieve `tramp-own-remote-path'") + nil))))) + + ;; Replace place holder `tramp-default-remote-path'. + (when elt1 + (setcdr elt1 + (append + (split-string (or default-remote-path "") ":" 'omit) + (cdr elt1))) + (setq remote-path (delq 'tramp-default-remote-path remote-path))) + + ;; Replace place holder `tramp-own-remote-path'. + (when elt2 + (setcdr elt2 + (append + (split-string (or own-remote-path "") ":" 'omit) + (cdr elt2))) + (setq remote-path (delq 'tramp-own-remote-path remote-path))) + + ;; Remove double entries. + (setq elt1 remote-path) + (while (consp elt1) + (while (and (car elt1) (setq elt2 (member (car elt1) (cdr elt1)))) + (setcar elt2 nil)) + (setq elt1 (cdr elt1))) + + ;; Remove non-existing directories. + (delq + nil + (mapcar + (lambda (x) + (and + (stringp x) + (file-directory-p (tramp-make-tramp-file-name vec x 'nohop)) x)) - x)) - remote-path))))) + remote-path)))))) (defun tramp-get-remote-locale (vec) "Determine remote locale, supporting UTF8 if possible." @@ -5266,8 +5396,8 @@ Nonexistent directories are removed from spec." (with-current-buffer (tramp-get-connection-buffer vec) (while candidates (goto-char (point-min)) - (if (string-match (format "^%s\r?$" (regexp-quote (car candidates))) - (buffer-string)) + (if (string-match-p (format "^%s\r?$" (regexp-quote (car candidates))) + (buffer-string)) (setq locale (car candidates) candidates nil) (setq candidates (cdr candidates))))) @@ -5287,7 +5417,7 @@ Nonexistent directories are removed from spec." ;; Check parameters. On busybox, "ls" output coloring is ;; enabled by default sometimes. So we try to disable it ;; when possible. $LS_COLORING is not supported there. - ;; Some "ls" versions are sensible wrt the order of + ;; Some "ls" versions are sensitive to the order of ;; arguments, they fail when "-al" is after the ;; "--color=never" argument (for example on FreeBSD). (when (tramp-send-command-and-check @@ -5300,36 +5430,23 @@ Nonexistent directories are removed from spec." (setq dl (cdr dl)))))) (tramp-error vec 'file-error "Couldn't find a proper `ls' command")))) -(defun tramp-get-ls-command-with-dired (vec) - "Check, whether the remote `ls' command supports the --dired option." - (save-match-data - (with-tramp-connection-property vec "ls-dired" - (tramp-message vec 5 "Checking, whether `ls --dired' works") - ;; Some "ls" versions are sensible wrt the order of arguments, - ;; they fail when "-al" is after the "--dired" argument (for - ;; example on FreeBSD). - (tramp-send-command-and-check - vec (format "%s --dired -al /dev/null" (tramp-get-ls-command vec)))))) - -(defun tramp-get-ls-command-with-quoting-style (vec) - "Check, whether the remote `ls' command supports the --quoting-style option." - (save-match-data - (with-tramp-connection-property vec "ls-quoting-style" - (tramp-message vec 5 "Checking, whether `ls --quoting-style=shell' works") +(defun tramp-get-ls-command-with (vec option) + "Return OPTION, if the remote `ls' command supports the OPTION option." + (with-tramp-connection-property vec (concat "ls" option) + (tramp-message vec 5 "Checking, whether `ls %s' works" option) + ;; Some "ls" versions are sensitive to the order of arguments, + ;; they fail when "-al" is after the "--dired" argument (for + ;; example on FreeBSD). Busybox does not support this kind of + ;; options. + (and + (not (tramp-send-command-and-check - vec (format "%s --quoting-style=shell -al /dev/null" - (tramp-get-ls-command vec)))))) - -(defun tramp-get-ls-command-with-w-option (vec) - "Check, whether the remote `ls' command supports the -w option." - (save-match-data - (with-tramp-connection-property vec "ls-w-option" - (tramp-message vec 5 "Checking, whether `ls -w' works") - ;; Option "-w" is available on BSD systems. No argument is - ;; given, because this could return wrong results in case "ls" - ;; supports the "-w NUM" argument, as for busyboxes. - (tramp-send-command-and-check - vec (format "%s -alw" (tramp-get-ls-command vec)))))) + vec + (format + "%s --help 2>&1 | grep -iq busybox" (tramp-get-ls-command vec)))) + (tramp-send-command-and-check + vec (format "%s %s -al /dev/null" (tramp-get-ls-command vec) option)) + option))) (defun tramp-get-test-command (vec) "Determine remote `test' command." @@ -5351,7 +5468,7 @@ Nonexistent directories are removed from spec." vec (format "( %s / -nt / )" (tramp-get-test-command vec))) (with-current-buffer (tramp-get-buffer vec) (goto-char (point-min)) - (when (looking-at (regexp-quote tramp-end-of-output)) + (when (looking-at-p (regexp-quote tramp-end-of-output)) (format "%s %%s -nt %%s" (tramp-get-test-command vec))))) (progn (tramp-send-command @@ -5413,7 +5530,7 @@ Nonexistent directories are removed from spec." tmp (tramp-send-command-and-read vec (format "%s -c '(\"%%N\" %%s)' /" result) 'noerror)) (unless (and (listp tmp) (stringp (car tmp)) - (string-match "^\\(`/'\\|‘/’\\)$" (car tmp)) + (string-match-p "^\\(`/'\\|‘/’\\)$" (car tmp)) (integerp (cadr tmp))) (setq result nil))) result))) @@ -5458,7 +5575,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." "%s -t %s %s" result (format-time-string "%Y%m%d%H%M.%S") - (file-remote-p tmpfile 'localname)))) + (tramp-compat-file-local-name tmpfile)))) (delete-file tmpfile)) result))) @@ -5466,12 +5583,30 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." "Determine remote `df' command." (with-tramp-connection-property vec "df" (tramp-message vec 5 "Finding a suitable `df' command") - (let ((result (tramp-find-executable vec "df" (tramp-get-remote-path vec)))) - (and - result - (tramp-send-command-and-check - vec (format "%s --block-size=1 --output=size,used,avail /" result)) - result)))) + (let ((df (tramp-find-executable vec "df" (tramp-get-remote-path vec))) + result) + (when df + (cond + ;; coreutils. + ((tramp-send-command-and-check + vec + (format + "%s /" + (setq result + (format "%s --block-size=1 --output=size,used,avail" df)))) + (tramp-set-connection-property vec "df-blocksize" 1) + result) + ;; POSIX.1 + ((tramp-send-command-and-check + vec (format "%s /" (setq result (format "%s -k" df)))) + (tramp-set-connection-property vec "df-blocksize" 1024) + result)))))) + +(defun tramp-get-remote-gio-monitor (vec) + "Determine remote `gio-monitor' command." + (with-tramp-connection-property vec "gio-monitor" + (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-gvfs-monitor-dir (vec) "Determine remote `gvfs-monitor-dir' command." @@ -5541,7 +5676,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." (tramp-get-remote-python vec) (if (equal id-format 'integer) "import os; print (os.getuid())" - "import os, pwd; print ('\\\"' + pwd.getpwuid(os.getuid())[0] + '\\\"')")))) + "import os, pwd; print ('\\\"' + pwd.getpwuid(os.getuid())[0] + '\\\"')")))) (defun tramp-get-remote-uid (vec id-format) "The uid of the remote connection VEC, in ID-FORMAT. @@ -5592,7 +5727,7 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-get-remote-python vec) (if (equal id-format 'integer) "import os; print (os.getgid())" - "import os, grp; print ('\\\"' + grp.getgrgid(os.getgid())[0] + '\\\"')")))) + "import os, grp; print ('\\\"' + grp.getgrgid(os.getgid())[0] + '\\\"')")))) (defun tramp-get-remote-gid (vec id-format) "The gid of the remote connection VEC, in ID-FORMAT. @@ -5658,14 +5793,14 @@ function cell is returned to be applied on a buffer." (tramp-find-inline-encoding vec) (tramp-get-connection-property (tramp-get-connection-process vec) prop nil))) - (prop1 (if (string-match "encoding" prop) + (prop1 (if (string-match-p "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 "remote" prop)) + (when (and coding (symbolp coding) (string-match-p "remote" prop)) (let ((name (symbol-name coding))) - (while (string-match (regexp-quote "-") name) + (while (string-match "-" name) (setq name (replace-match "_" nil t name))) (tramp-maybe-send-script vec (symbol-value coding) name) (setq coding name))) @@ -5675,35 +5810,35 @@ function cell is returned to be applied on a buffer." ;; Return the value. (cond ((and compress (symbolp coding)) - (if (string-match "decompress" prop1) + (if (string-match-p "decompress" prop1) `(lambda (beg end) (,coding beg end) (let ((coding-system-for-write 'binary) (coding-system-for-read 'binary)) (apply - 'tramp-call-process-region ',vec (point-min) (point-max) + #'tramp-call-process-region ',vec (point-min) (point-max) (car (split-string ,compress)) t t nil (cdr (split-string ,compress))))) `(lambda (beg end) (let ((coding-system-for-write 'binary) (coding-system-for-read 'binary)) (apply - 'tramp-call-process-region ',vec beg end + #'tramp-call-process-region ',vec beg end (car (split-string ,compress)) t t nil (cdr (split-string ,compress)))) (,coding (point-min) (point-max))))) ((symbolp coding) coding) - ((and compress (string-match "decoding" prop)) + ((and compress (string-match-p "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 "local" prop) + ((and (string-match-p "local" prop) (memq system-type '(windows-nt))) "(%s | \"%s\")") - ((string-match "local" prop) "(%s | %s)") + ((string-match-p "local" prop) "(%s | %s)") (t "(%s | %s >%%s)")) coding compress)) (compress @@ -5711,14 +5846,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 "local" prop) + (if (and (string-match-p "local" prop) (memq system-type '(windows-nt))) "(%s <%%s | \"%s\")" "(%s <%%s | %s)") compress coding)) - ((string-match "decoding" prop) + ((string-match-p "decoding" prop) (cond - ((string-match "local" prop) (format "%s" coding)) + ((string-match-p "local" prop) (format "%s" coding)) (t (format "%s >%%s" coding)))) (t (format "%s <%%s" coding))))))) @@ -5742,10 +5877,6 @@ function cell is returned to be applied on a buffer." ;; gets confused about the file locking status. Try to find out why ;; the workaround doesn't work. ;; -;; * Allow out-of-band methods as _last_ multi-hop. Open a connection -;; until the last but one hop via `start-file-process'. Apply it -;; also for ftp and smb. -;; ;; * WIBNI if we had a command "trampclient"? If I was editing in ;; some shell with root privileges, it would be nice if I could ;; just call @@ -5819,5 +5950,11 @@ function cell is returned to be applied on a buffer." ;; which could immediately be passed on to the remote side, and ;; later on checks the return value of those calls as and when ;; needed. (Stefan Monnier) +;; +;; * Implement detaching/re-attaching remote sessions. By this, a +;; session could be reused after a connection loss. Use dtach, or +;; screen, or tmux, or mosh. +;; +;; * Implement `:stderr' of `make-process' as pipe process. ;;; tramp-sh.el ends here diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 894c0de4aa7..9b87ed40cb0 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -27,6 +27,7 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) (require 'tramp) ;; Define SMB method ... @@ -37,30 +38,27 @@ ;; ... and add it to the method list. ;;;###tramp-autoload (unless (memq system-type '(cygwin windows-nt)) - (add-to-list 'tramp-methods - `(,tramp-smb-method - ;; We define an empty command, because `tramp-smb-call-winexe' - ;; opens already the powershell. Used in `tramp-handle-shell-command'. - (tramp-remote-shell "") - ;; This is just a guess. We don't know whether the share "C$" - ;; is available for public use, and whether the user has write - ;; access. - (tramp-tmpdir "/C$/Temp") - ;; Another guess. We might implement a better check later on. - (tramp-case-insensitive t)))) + (tramp--with-startup + (add-to-list 'tramp-methods + `(,tramp-smb-method + ;; This is just a guess. We don't know whether the share "C$" + ;; is available for public use, and whether the user has write + ;; access. + (tramp-tmpdir "/C$/Temp") + ;; Another guess. We might implement a better check later on. + (tramp-case-insensitive t))))) ;; Add a default for `tramp-default-user-alist'. Rule: For the SMB method, ;; the anonymous user is chosen. ;;;###tramp-autoload -(add-to-list 'tramp-default-user-alist - `(,(concat "\\`" tramp-smb-method "\\'") nil nil)) +(tramp--with-startup + (add-to-list 'tramp-default-user-alist + `(,(concat "\\`" tramp-smb-method "\\'") nil nil)) -;; Add completion function for SMB method. -;;;###tramp-autoload -(eval-after-load 'tramp - '(tramp-set-completion-function - tramp-smb-method - '((tramp-parse-netrc "~/.netrc")))) + ;; Add completion function for SMB method. + (tramp-set-completion-function + tramp-smb-method + '((tramp-parse-netrc "~/.netrc")))) ;;;###tramp-autoload (defcustom tramp-smb-program "smbclient" @@ -101,7 +99,7 @@ call, letting the SMB client use the default one." (defconst tramp-smb-errors (mapconcat - 'identity + #'identity `(;; Connection error / timeout / unknown command. "Connection\\( to \\S-+\\)? failed" "Read from server failed, maybe it closed the connection" @@ -119,6 +117,7 @@ call, letting the SMB client use the default one." "ERRnoaccess" "ERRnomem" "ERRnosuchshare" + ;; See /usr/include/samba-4.0/core/ntstatus.h. ;; Windows 4.0 (Windows NT), Windows 5.0 (Windows 2000), ;; Windows 5.1 (Windows XP), Windows 5.2 (Windows Server 2003), ;; Windows 6.0 (Windows Vista), Windows 6.1 (Windows 7), @@ -129,6 +128,7 @@ call, letting the SMB client use the default one." "NT_STATUS_CANNOT_DELETE" "NT_STATUS_CONNECTION_DISCONNECTED" "NT_STATUS_CONNECTION_REFUSED" + "NT_STATUS_CONNECTION_RESET" "NT_STATUS_DIRECTORY_NOT_EMPTY" "NT_STATUS_DUPLICATE_NAME" "NT_STATUS_FILE_IS_A_DIRECTORY" @@ -143,12 +143,14 @@ call, letting the SMB client use the default one." "NT_STATUS_NO_LOGON_SERVERS" "NT_STATUS_NO_SUCH_FILE" "NT_STATUS_NO_SUCH_USER" + "NT_STATUS_NOT_A_DIRECTORY" "NT_STATUS_OBJECT_NAME_COLLISION" "NT_STATUS_OBJECT_NAME_INVALID" "NT_STATUS_OBJECT_NAME_NOT_FOUND" "NT_STATUS_OBJECT_PATH_SYNTAX_BAD" "NT_STATUS_PASSWORD_MUST_CHANGE" "NT_STATUS_RESOURCE_NAME_NOT_FOUND" + "NT_STATUS_REVISION_MISMATCH" "NT_STATUS_SHARING_VIOLATION" "NT_STATUS_TRUSTED_RELATIONSHIP_FAILURE" "NT_STATUS_UNSUCCESSFUL" @@ -211,7 +213,7 @@ See `tramp-actions-before-shell' for more info.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-smb-file-name-handler-alist - '(;; `access-file' performed by default handler. + '((access-file . tramp-handle-access-file) (add-name-to-file . tramp-smb-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-smb-handle-copy-directory) @@ -225,11 +227,12 @@ See `tramp-actions-before-shell' for more info.") . tramp-handle-directory-files-and-attributes) (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) + (exec-path . ignore) (expand-file-name . tramp-smb-handle-expand-file-name) - (file-accessible-directory-p . tramp-smb-handle-file-directory-p) + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . tramp-smb-handle-file-acl) (file-attributes . tramp-smb-handle-file-attributes) - (file-directory-p . tramp-smb-handle-file-directory-p) + (file-directory-p . tramp-handle-file-directory-p) (file-file-equal-p . tramp-handle-file-equal-p) (file-executable-p . tramp-handle-file-exists-p) (file-exists-p . tramp-handle-file-exists-p) @@ -257,7 +260,6 @@ See `tramp-actions-before-shell' for more info.") (file-truename . tramp-handle-file-truename) (file-writable-p . tramp-smb-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) - ;; `find-file-noselect' performed by default handler. ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-smb-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) @@ -266,6 +268,7 @@ See `tramp-actions-before-shell' for more info.") (make-directory . tramp-smb-handle-make-directory) (make-directory-internal . tramp-smb-handle-make-directory-internal) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-process . ignore) (make-symbolic-link . tramp-smb-handle-make-symbolic-link) (process-file . tramp-smb-handle-process-file) (rename-file . tramp-smb-handle-rename-file) @@ -278,6 +281,7 @@ See `tramp-actions-before-shell' for more info.") (start-file-process . tramp-smb-handle-start-file-process) (substitute-in-file-name . tramp-smb-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) @@ -316,8 +320,9 @@ This can be used to disable echo etc." ;;;###tramp-autoload (defsubst tramp-smb-file-name-p (filename) "Check if it's a filename for SMB servers." - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-smb-method)) + (and (tramp-tramp-file-p filename) + (string= (tramp-file-name-method (tramp-dissect-file-name filename)) + tramp-smb-method))) ;;;###tramp-autoload (defun tramp-smb-file-name-handler (operation &rest args) @@ -331,8 +336,9 @@ pass to the OPERATION." ;;;###tramp-autoload (unless (memq system-type '(cygwin windows-nt)) - (tramp-register-foreign-file-name-handler - 'tramp-smb-file-name-p 'tramp-smb-file-name-handler)) + (tramp--with-startup + (tramp-register-foreign-file-name-handler + #'tramp-smb-file-name-p #'tramp-smb-file-name-handler))) ;; File name primitives. @@ -365,8 +371,8 @@ pass to the OPERATION." (delete-file newname))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v2 (file-name-directory v2-localname)) - (tramp-flush-file-property v2 v2-localname) + (tramp-flush-file-properties v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname) (unless (tramp-smb-send-command v1 @@ -401,7 +407,7 @@ pass to the OPERATION." (if copy-contents ;; We must do it file-wise. (tramp-run-real-handler - 'copy-directory (list dirname newname keep-date parents copy-contents)) + #'copy-directory (list dirname newname keep-date parents copy-contents)) (setq dirname (expand-file-name dirname) newname (expand-file-name newname)) @@ -444,13 +450,6 @@ pass to the OPERATION." (if (not (file-directory-p newname)) (make-directory newname parents)) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - (let* ((share (tramp-smb-get-share v)) (localname (file-name-as-directory (replace-regexp-in-string @@ -459,9 +458,7 @@ pass to the OPERATION." (expand-file-name tramp-temp-name-prefix (tramp-compat-temporary-file-directory)))) - (args (list (concat "//" host "/" share) "-E")) - ;; We do not want to run timers. - timer-list timer-idle-list) + (args (list (concat "//" host "/" share) "-E"))) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -477,7 +474,8 @@ pass to the OPERATION." (append args (list "-D" (tramp-unquote-shell-quote-argument localname) - "-c" (shell-quote-argument "tar qc - *") + "-c" (tramp-unquote-shell-quote-argument + "tar qc - *") "|" "tar" "xfC" "-" (tramp-unquote-shell-quote-argument tmpdir))) @@ -488,7 +486,8 @@ pass to the OPERATION." args (list "-D" (tramp-unquote-shell-quote-argument localname) - "-c" (shell-quote-argument "tar qx -"))))) + "-c" (tramp-unquote-shell-quote-argument + "tar qx -"))))) (unwind-protect (with-temp-buffer @@ -514,15 +513,15 @@ pass to the OPERATION." ;; password can be handled. (let* ((default-directory tmpdir) (p (apply - 'start-process + #'start-process (tramp-get-connection-name v) (tramp-get-connection-buffer v) tramp-smb-program args))) (tramp-message - v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" v) - (process-put p 'adjust-window-size-function 'ignore) + v 6 "%s" (string-join (process-command p) " ")) + (process-put p 'vector v) + (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) (tramp-process-actions p v nil tramp-smb-actions-with-tar) @@ -531,8 +530,8 @@ pass to the OPERATION." (tramp-message v 6 "\n%s" (buffer-string)))) ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") (when t1 (delete-directory tmpdir 'recursive)))) ;; Handle KEEP-DATE argument. @@ -549,13 +548,13 @@ pass to the OPERATION." ;; When newname did exist, we have wrong cached values. (when t2 (with-parsed-tramp-file-name newname nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname)))) ;; We must do it file-wise. (t (tramp-run-real-handler - 'copy-directory (list dirname newname keep-date parents))))))))) + #'copy-directory (list dirname newname keep-date parents))))))))) (defun tramp-smb-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -589,14 +588,16 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (expand-file-name (file-name-nondirectory filename) newname))) (with-parsed-tramp-file-name newname nil - (when (and (not ok-if-already-exists) - (file-exists-p newname)) + (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (unless (tramp-smb-get-share v) (tramp-error v 'file-error "Target `%s' must contain a share name" newname)) @@ -630,8 +631,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (with-parsed-tramp-file-name directory nil ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (unless (tramp-smb-send-command v (format "%s \"%s\"" @@ -656,8 +657,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (with-parsed-tramp-file-name filename nil ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (unless (tramp-smb-send-command v (format "%s \"%s\"" @@ -673,13 +674,13 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (defun tramp-smb-handle-directory-files (directory &optional full match nosort) "Like `directory-files' for Tramp files." - (let ((result (mapcar 'directory-file-name + (let ((result (mapcar #'directory-file-name (file-name-all-completions "" directory)))) ;; Discriminate with regexp. (when match (setq result (delete nil - (mapcar (lambda (x) (when (string-match match x) x)) + (mapcar (lambda (x) (when (string-match-p match x) x)) result)))) ;; Append directory. (when full @@ -688,19 +689,21 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (lambda (x) (format "%s/%s" directory x)) result))) ;; Sort them if necessary. - (unless nosort (setq result (sort result 'string-lessp))) + (unless nosort (setq result (sort result #'string-lessp))) result)) (defun tramp-smb-handle-expand-file-name (name &optional dir) "Like `expand-file-name' for Tramp files." ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". (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 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)) + (tramp-run-real-handler #'expand-file-name (list name nil)) ;; Dissect NAME. (with-parsed-tramp-file-name name nil ;; Tilde expansion if necessary. We use the user name as share, @@ -713,92 +716,83 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (match-string 1 localname)) nil nil localname))) ;; Make the file name absolute. - (unless (tramp-run-real-handler 'file-name-absolute-p (list localname)) + (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) ;; No tilde characters in file name, do normal ;; `expand-file-name' (this does "/./" and "/../"). (tramp-make-tramp-file-name - method user domain host port - (tramp-run-real-handler 'expand-file-name (list localname)))))) + v (tramp-run-real-handler #'expand-file-name (list localname)))))) (defun tramp-smb-action-get-acl (proc vec) "Read ACL data from connection buffer." (unless (process-live-p proc) ;; Accept pending output. - (while (tramp-accept-process-output proc 0.1)) + (while (tramp-accept-process-output proc)) (with-current-buffer (tramp-get-connection-buffer vec) ;; There might be a hidden password prompt. (widen) (tramp-message vec 10 "\n%s" (buffer-string)) (goto-char (point-min)) - (while (and (not (eobp)) (not (looking-at "^REVISION:"))) + (while (and (not (eobp)) (not (looking-at-p "^REVISION:"))) (forward-line) (delete-region (point-min) (point))) - (while (and (not (eobp)) (looking-at "^.+:.+")) + (while (and (not (eobp)) (looking-at-p "^.+:.+")) (forward-line)) (delete-region (point) (point-max)) (throw 'tramp-action 'ok)))) (defun tramp-smb-handle-file-acl (filename) "Like `file-acl' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-tramp-file-property v localname "file-acl" - (when (executable-find tramp-smb-acl-program) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - - (let* ((share (tramp-smb-get-share v)) - (localname (replace-regexp-in-string - "\\\\" "/" (tramp-smb-get-localname v))) - (args (list (concat "//" host "/" share) "-E")) - ;; We do not want to run timers. - timer-list timer-idle-list) - - (if (not (zerop (length user))) - (setq args (append args (list "-U" user))) - (setq args (append args (list "-N")))) - - (when domain (setq args (append args (list "-W" domain)))) - (when port (setq args (append args (list "-p" port)))) - (when tramp-smb-conf - (setq args (append args (list "-s" tramp-smb-conf)))) - (setq - args - (append args (list (tramp-unquote-shell-quote-argument localname) - "2>/dev/null"))) - - (unwind-protect - (with-temp-buffer - ;; Set the transfer process properties. - (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) - (tramp-set-connection-property - v "process-buffer" (current-buffer)) - - ;; Use an asynchronous processes. By this, password - ;; can be handled. - (let ((p (apply - 'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - tramp-smb-acl-program args))) - - (tramp-message - v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" v) - (process-put p 'adjust-window-size-function 'ignore) - (set-process-query-on-exit-flag p nil) - (tramp-process-actions p v nil tramp-smb-actions-get-acl) - (when (> (point-max) (point-min)) - (substring-no-properties (buffer-string))))) - - ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil))))))) + (ignore-errors + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-acl" + (when (executable-find tramp-smb-acl-program) + (let* ((share (tramp-smb-get-share v)) + (localname (replace-regexp-in-string + "\\\\" "/" (tramp-smb-get-localname v))) + (args (list (concat "//" host "/" share) "-E"))) + + (if (not (zerop (length user))) + (setq args (append args (list "-U" user))) + (setq args (append args (list "-N")))) + + (when domain (setq args (append args (list "-W" domain)))) + (when port (setq args (append args (list "-p" port)))) + (when tramp-smb-conf + (setq args (append args (list "-s" tramp-smb-conf)))) + (setq + args + (append args (list (tramp-unquote-shell-quote-argument localname) + "2>/dev/null"))) + + (unwind-protect + (with-temp-buffer + ;; Set the transfer process properties. + (tramp-set-connection-property + v "process-name" (buffer-name (current-buffer))) + (tramp-set-connection-property + v "process-buffer" (current-buffer)) + + ;; Use an asynchronous process. By this, password can + ;; be handled. + (let ((p (apply + #'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + tramp-smb-acl-program args))) + + (tramp-message + v 6 "%s" (string-join (process-command p) " ")) + (process-put p 'vector v) + (process-put p 'adjust-window-size-function #'ignore) + (set-process-query-on-exit-flag p nil) + (tramp-process-actions p v nil tramp-smb-actions-get-acl) + (when (> (point-max) (point-min)) + (substring-no-properties (buffer-string))))) + + ;; Reset the transfer process properties. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer")))))))) (defun tramp-smb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." @@ -825,19 +819,19 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Check result. (when entry - (list (and (string-match "d" (nth 1 entry)) - t) ;0 file type - -1 ;1 link count - uid ;2 uid - gid ;3 gid - '(0 0) ;4 atime - (nth 3 entry) ;5 mtime - '(0 0) ;6 ctime - (nth 2 entry) ;7 size - (nth 1 entry) ;8 mode - nil ;9 gid weird - inode ;10 inode number - device)))))))) ;11 file system number + (list (and (string-match-p "d" (nth 1 entry)) + t) ;0 file type + -1 ;1 link count + uid ;2 uid + gid ;3 gid + tramp-time-dont-know ;4 atime + (nth 3 entry) ;5 mtime + tramp-time-dont-know ;6 ctime + (nth 2 entry) ;7 size + (nth 1 entry) ;8 mode + nil ;9 gid weird + inode ;10 inode number + device)))))))) ;11 file system number (defun tramp-smb-do-file-attributes-with-stat (vec &optional id-format) "Implement `file-attributes' for Tramp files using stat command." @@ -915,13 +909,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (list id link uid gid atime mtime ctime size mode nil inode (tramp-get-device vec)))))))) -(defun tramp-smb-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - (and (file-exists-p filename) - (eq ?d - (aref (tramp-compat-file-attribute-modes (file-attributes filename)) - 0)))) - (defun tramp-smb-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name (file-truename filename) nil @@ -949,15 +936,14 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." filename (with-parsed-tramp-file-name (expand-file-name directory) nil (with-tramp-file-property v localname "file-name-all-completions" - (save-match-data - (delete-dups - (mapcar - (lambda (x) - (list - (if (string-match "d" (nth 1 x)) - (file-name-as-directory (nth 0 x)) - (nth 0 x)))) - (tramp-smb-get-file-entries directory)))))))) + (delete-dups + (mapcar + (lambda (x) + (list + (if (string-match-p "d" (nth 1 x)) + (file-name-as-directory (nth 0 x)) + (nth 0 x)))) + (tramp-smb-get-file-entries directory))))))) (defun tramp-smb-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." @@ -972,21 +958,19 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (goto-char (point-min)) (forward-line) (when (looking-at - (concat "[[:space:]]*\\([[:digit:]]+\\)" - " blocks of size \\([[:digit:]]+\\)" - "\\. \\([[:digit:]]+\\) blocks available")) - (setq blocksize (string-to-number (concat (match-string 2) "e0")) - total (* blocksize - (string-to-number (concat (match-string 1) "e0"))) - avail (* blocksize - (string-to-number (concat (match-string 3) "e0"))))) + (eval-when-compile + (concat "[[:space:]]*\\([[:digit:]]+\\)" + " blocks of size \\([[:digit:]]+\\)" + "\\. \\([[:digit:]]+\\) blocks available"))) + (setq blocksize (string-to-number (match-string 2)) + total (* blocksize (string-to-number (match-string 1))) + avail (* blocksize (string-to-number (match-string 3))))) (forward-line) (when (looking-at "Total number of bytes: \\([[:digit:]]+\\)") ;; The used number of bytes is not part of the result. As ;; side effect, we store it as file property. (tramp-set-file-property - v localname "used-bytes" - (string-to-number (concat (match-string 1) "e0")))) + v localname "used-bytes" (string-to-number (match-string 1)))) ;; Result. (when (and total avail) (list total (- total avail) avail))))))) @@ -994,7 +978,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 + (string-match-p "w" (or (tramp-compat-file-attribute-modes (file-attributes filename)) "")) (let ((dir (file-name-directory filename))) @@ -1014,6 +998,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Called from `dired-add-entry'. (setq filename (file-name-as-directory filename)) (setq filename (directory-file-name filename))) + ;; Check, whether directory is accessible. + (unless wildcard + (access-file filename "Reading directory")) (with-parsed-tramp-file-name filename nil (with-tramp-progress-reporter v 0 (format "Opening directory %s" filename) (save-match-data @@ -1046,7 +1033,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Check for matching entries. (mapcar (lambda (x) - (when (string-match + (when (string-match-p (format "^%s" base) (nth 0 x)) x)) entries) @@ -1058,17 +1045,17 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (sort entries (lambda (x y) - (if (string-match "t" switches) + (if (string-match-p "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 "F" switches) + (when (string-match-p "F" switches) (mapc (lambda (x) - (when (not (zerop (length (car x)))) + (unless (zerop (length (car x))) (cond ((char-equal ?d (string-to-char (nth 1 x))) (setcar x (concat (car x) "/"))) @@ -1086,7 +1073,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Print entries. (mapc (lambda (x) - (when (not (zerop (length (nth 0 x)))) + (unless (zerop (length (nth 0 x))) (let ((attr (when (tramp-smb-get-stat-capability v) (ignore-errors @@ -1094,7 +1081,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 "l" switches) + (when (string-match-p "l" switches) (insert (format "%10s %3d %-8s %-8s %8s %s " @@ -1104,10 +1091,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (or (tramp-compat-file-attribute-group-id attr) "nogroup") (or (tramp-compat-file-attribute-size attr) (nth 2 x)) (format-time-string - (if (time-less-p (time-subtract (current-time) (nth 3 x)) - tramp-half-a-year) + (if (time-less-p + ;; Half a year. + (time-since (nth 3 x)) (days-to-time 183)) "%b %e %R" - "%b %e %Y") + "%b %e %Y") (nth 3 x))))) ; date ;; We mark the file name. The inserted name could be @@ -1124,7 +1112,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 "l" switches) + (when (and (string-match-p "l" switches) (stringp (tramp-compat-file-attribute-type attr))) (insert " -> " (tramp-compat-file-attribute-type attr)))) @@ -1139,18 +1127,17 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (unless (file-name-absolute-p dir) (setq dir (expand-file-name dir default-directory))) (with-parsed-tramp-file-name dir nil - (save-match-data - (let* ((ldir (file-name-directory dir))) - ;; Make missing directory parts. - (when (and parents - (tramp-smb-get-share v) - (not (file-directory-p ldir))) - (make-directory ldir parents)) - ;; Just do it. - (when (file-directory-p ldir) - (make-directory-internal dir)) - (unless (file-directory-p dir) - (tramp-error v 'file-error "Couldn't make directory %s" dir)))))) + (let* ((ldir (file-name-directory dir))) + ;; Make missing directory parts. + (when (and parents + (tramp-smb-get-share v) + (not (file-directory-p ldir))) + (make-directory ldir parents)) + ;; Just do it. + (when (file-directory-p ldir) + (make-directory-internal dir)) + (unless (file-directory-p dir) + (tramp-error v 'file-error "Couldn't make directory %s" dir))))) (defun tramp-smb-handle-make-directory-internal (directory) "Like `make-directory-internal' for Tramp files." @@ -1158,21 +1145,19 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (unless (file-name-absolute-p directory) (setq directory (expand-file-name directory default-directory))) (with-parsed-tramp-file-name directory nil - (save-match-data - (let* ((file (tramp-smb-get-localname v))) - (when (file-directory-p (file-name-directory directory)) - (tramp-smb-send-command - v - (if (tramp-smb-get-cifs-capabilities v) - (format "posix_mkdir \"%s\" %o" file (default-file-modes)) - (format "mkdir \"%s\"" file))) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)) - (unless (file-directory-p directory) - (tramp-error - v 'file-error "Couldn't make directory %s" directory)))))) + (let* ((file (tramp-smb-get-localname v))) + (when (file-directory-p (file-name-directory directory)) + (tramp-smb-send-command + v + (if (tramp-smb-get-cifs-capabilities v) + (format "posix_mkdir \"%s\" %o" file (default-file-modes)) + (format "mkdir \"%s\"" file))) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname)) + (unless (file-directory-p directory) + (tramp-error v 'file-error "Couldn't make directory %s" directory))))) (defun tramp-smb-handle-make-symbolic-link (target linkname &optional ok-if-already-exists) @@ -1182,15 +1167,17 @@ of the symlink. If TARGET is a Tramp file, only the localname component is used as the target of the symlink." (if (not (tramp-tramp-file-p (expand-file-name linkname))) (tramp-run-real-handler - 'make-symbolic-link (list target linkname ok-if-already-exists)) + #'make-symbolic-link (list target linkname ok-if-already-exists)) (with-parsed-tramp-file-name linkname nil ;; If TARGET is a Tramp name, use just the localname component. - (when (and (tramp-tramp-file-p target) - (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target))))) + ;; Don't check for a proper method. + (let ((non-essential t)) + (when (and (tramp-tramp-file-p target) + (tramp-file-name-equal-p v (tramp-dissect-file-name target))) + (setq target + (tramp-file-name-localname + (tramp-dissect-file-name (expand-file-name target)))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -1215,8 +1202,8 @@ component is used as the target of the symlink." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (unless (tramp-smb-send-command @@ -1226,7 +1213,7 @@ component is used as the target of the symlink." (tramp-error v 'file-error "error with make-symbolic-link, see buffer `%s' for details" - (buffer-name))))))) + (tramp-get-connection-buffer v))))))) (defun tramp-smb-handle-process-file (program &optional infile destination display &rest args) @@ -1239,8 +1226,6 @@ component is used as the target of the symlink." (let* ((name (file-name-nondirectory program)) (name1 name) (i 0) - ;; We do not want to run timers. - timer-list timer-idle-list input tmpinput outbuf command ret) ;; Determine input. @@ -1251,8 +1236,7 @@ component is used as the target of the symlink." (setq input (with-parsed-tramp-file-name infile nil localname)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) - tmpinput - (tramp-make-tramp-file-name method user domain host port input)) + tmpinput (tramp-make-tramp-file-name v input)) (copy-file infile tmpinput t)) ;; Transform input into a filename powershell does understand. (setq input (format "//%s%s" host input))) @@ -1282,7 +1266,7 @@ component is used as the target of the symlink." (setq outbuf (current-buffer)))) ;; Construct command. - (setq command (mapconcat 'identity (cons program args) " ") + (setq command (string-join (cons program args) " ") command (if input (format "get-content %s | & %s" @@ -1333,14 +1317,14 @@ component is used as the target of the symlink." ;; Cleanup. We remove all file cache values for the connection, ;; because the remote process could have changed them. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") (when tmpinput (delete-file tmpinput)) (unless outbuf (kill-buffer (tramp-get-connection-property v "process-buffer" nil))) (unless process-file-side-effects - (tramp-flush-directory-property v "")) + (tramp-flush-directory-properties v "")) ;; Return exit status. (if (equal ret -1) @@ -1353,54 +1337,55 @@ component is used as the target of the symlink." (setq filename (expand-file-name filename) newname (expand-file-name newname)) - (when (and (not ok-if-already-exists) - (file-exists-p newname)) - (tramp-error - (tramp-dissect-file-name - (if (tramp-tramp-file-p filename) filename newname)) - 'file-already-exists newname)) - - (with-tramp-progress-reporter - (tramp-dissect-file-name - (if (tramp-tramp-file-p filename) filename newname)) - 0 (format "Renaming %s to %s" filename newname) - - (if (and (not (file-exists-p newname)) - (tramp-equal-remote filename newname) - (string-equal - (tramp-smb-get-share (tramp-dissect-file-name filename)) - (tramp-smb-get-share (tramp-dissect-file-name newname)))) - ;; We can rename directly. - (with-parsed-tramp-file-name filename v1 - (with-parsed-tramp-file-name newname v2 - - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v1 (file-name-directory v1-localname)) - (tramp-flush-file-property v1 v1-localname) - (tramp-flush-file-property v2 (file-name-directory v2-localname)) - (tramp-flush-file-property v2 v2-localname) - (unless (tramp-smb-get-share v2) - (tramp-error - v2 'file-error "Target `%s' must contain a share name" newname)) - (unless (tramp-smb-send-command - v2 (format "rename \"%s\" \"%s\"" - (tramp-smb-get-localname v1) - (tramp-smb-get-localname v2))) - (tramp-error v2 'file-error "Cannot rename `%s'" filename)))) - - ;; We must rename via copy. - (copy-file - filename newname ok-if-already-exists 'keep-time 'preserve-uid-gid) - (if (file-directory-p filename) - (delete-directory filename 'recursive) - (delete-file filename))))) + (with-parsed-tramp-file-name + (if (tramp-tramp-file-p filename) filename newname) nil + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (with-tramp-progress-reporter + v 0 (format "Renaming %s to %s" filename newname) + + (if (and (not (file-exists-p newname)) + (tramp-equal-remote filename newname) + (string-equal + (tramp-smb-get-share (tramp-dissect-file-name filename)) + (tramp-smb-get-share (tramp-dissect-file-name newname)))) + ;; We can rename directly. + (with-parsed-tramp-file-name filename v1 + (with-parsed-tramp-file-name newname v2 + + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties + v1 (file-name-directory v1-localname)) + (tramp-flush-file-properties v1 v1-localname) + (tramp-flush-file-properties + v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname) + (unless (tramp-smb-get-share v2) + (tramp-error + v2 'file-error + "Target `%s' must contain a share name" newname)) + (unless (tramp-smb-send-command + v2 (format "rename \"%s\" \"%s\"" + (tramp-smb-get-localname v1) + (tramp-smb-get-localname v2))) + (tramp-error v2 'file-error "Cannot rename `%s'" filename)))) + + ;; We must rename via copy. + (copy-file + filename newname ok-if-already-exists 'keep-time 'preserve-uid-gid) + (if (file-directory-p filename) + (delete-directory filename 'recursive) + (delete-file filename)))))) (defun tramp-smb-action-set-acl (proc vec) - "Read ACL data from connection buffer." + "Set ACL data." (unless (process-live-p proc) ;; Accept pending output. - (while (tramp-accept-process-output proc 0.1)) + (while (tramp-accept-process-output proc)) (with-current-buffer (tramp-get-connection-buffer vec) (tramp-message vec 10 "\n%s" (buffer-string)) (throw 'tramp-action 'ok)))) @@ -1409,23 +1394,15 @@ component is used as the target of the symlink." "Like `set-file-acl' for Tramp files." (ignore-errors (with-parsed-tramp-file-name filename nil - (when (and (stringp acl-string) (executable-find tramp-smb-acl-program)) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - (tramp-set-file-property v localname "file-acl" 'undef) + (tramp-flush-file-property v localname "file-acl") + (when (and (stringp acl-string) (executable-find tramp-smb-acl-program)) (let* ((share (tramp-smb-get-share v)) (localname (replace-regexp-in-string "\\\\" "/" (tramp-smb-get-localname v))) (args (list (concat "//" host "/" share) "-E" "-S" (replace-regexp-in-string - "\n" "," acl-string))) - ;; We do not want to run timers. - timer-list timer-idle-list) + "\n" "," acl-string)))) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -1452,15 +1429,14 @@ component is used as the target of the symlink." ;; Use an asynchronous process. By this, password can ;; be handled. (let ((p (apply - 'start-process + #'start-process (tramp-get-connection-name v) (tramp-get-connection-buffer v) tramp-smb-acl-program args))) - (tramp-message - v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" v) - (process-put p 'adjust-window-size-function 'ignore) + (tramp-message v 6 "%s" (string-join (process-command p) " ")) + (process-put p 'vector v) + (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) (tramp-process-actions p v nil tramp-smb-actions-set-acl) (goto-char (point-max)) @@ -1478,14 +1454,14 @@ component is used as the target of the symlink." t))) ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil))))))) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer"))))))) (defun tramp-smb-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil (when (tramp-smb-get-cifs-capabilities v) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v localname) (unless (tramp-smb-send-command v (format "chmod \"%s\" %o" (tramp-smb-get-localname v) mode)) (tramp-error @@ -1502,12 +1478,10 @@ component is used as the target of the symlink." (get-buffer-create buffer) ;; BUFFER can be nil. We use a temporary buffer. (generate-new-buffer tramp-temp-buffer-name))) - (command (mapconcat 'identity (cons program args) " ")) + (command (string-join (cons program args) " ")) (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) (name1 name) - (i 0) - ;; We do not want to run timers. - timer-list timer-idle-list) + (i 0)) (unwind-protect (save-excursion (save-restriction @@ -1535,13 +1509,13 @@ component is used as the target of the symlink." ;; Save exit. (with-current-buffer (tramp-get-connection-buffer v) - (if (string-match tramp-temp-buffer-name (buffer-name)) + (if (string-match-p tramp-temp-buffer-name (buffer-name)) (progn (set-process-buffer (tramp-get-connection-process v) nil) (kill-buffer (current-buffer))) (set-buffer-modified-p bmp))) - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil))))) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer"))))) (defun tramp-smb-handle-substitute-in-file-name (filename) "Like `handle-substitute-in-file-name' for Tramp files. @@ -1557,7 +1531,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (concat (file-remote-p filename) (replace-match "\\1" nil nil localname))))) (condition-case nil - (tramp-run-real-handler 'substitute-in-file-name (list filename)) + (tramp-run-real-handler #'substitute-in-file-name (list filename)) (error filename)))) (defun tramp-smb-handle-write-region @@ -1574,8 +1548,8 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (let ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) @@ -1584,7 +1558,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." ;; 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 (list start end tmpfile append 'no-message lockname)) (with-tramp-progress-reporter v 3 (format "Moving tmp file %s to %s" tmpfile filename) @@ -1644,6 +1618,13 @@ If VEC has no cifs capabilities, exchange \"/\" by \"\\\\\"." (when (string-match "\\(\\$\\$\\)\\(/\\|$\\)" localname) (setq localname (replace-match "$" nil nil localname 1))) + ;; A period followed by a space, or trailing periods and spaces, + ;; are not supported. + (when (string-match-p "\\. \\|\\.$\\| $" localname) + (tramp-error + vec 'file-error + "Invalid file name %s" (tramp-make-tramp-file-name vec localname))) + localname))) ;; Share names of a host are cached. It is very unlikely that the @@ -1793,7 +1774,7 @@ Result is the list (LOCALNAME MODE SIZE MTIME)." (cl-return)) ;; weekday. - (if (string-match "\\(\\w+\\)$" line) + (if (string-match-p "\\(\\w+\\)$" line) (setq line (substring line 0 -5)) (cl-return)) @@ -1814,12 +1795,12 @@ Result is the list (LOCALNAME MODE SIZE MTIME)." (if (string-match "\\([ACDEHNORrsSTV]+\\)?$" line) (setq mode (or (match-string 1 line) "") - mode (save-match-data (format + mode (format "%s%s" - (if (string-match "D" mode) "d" "-") + (if (string-match-p "D" mode) "d" "-") (mapconcat (lambda (_x) "") " " - (concat "r" (if (string-match "R" mode) "-" "w") "x")))) + (concat "r" (if (string-match-p "R" mode) "-" "w") "x"))) line (substring line 0 -6)) (cl-return)) @@ -1835,7 +1816,7 @@ Result is the list (LOCALNAME MODE SIZE MTIME)." sec min hour day (cdr (assoc (downcase month) parse-time-months)) year) - '(0 0))) + tramp-time-dont-know)) (list localname mode size mtime)))) (defun tramp-smb-get-cifs-capabilities (vec) @@ -1908,8 +1889,8 @@ If ARGUMENT is non-nil, use it as argument for tramp-smb-version (tramp-get-connection-property vec "smbclient-version" tramp-smb-version)) - (tramp-flush-directory-property vec "") - (tramp-flush-connection-property vec)) + (tramp-flush-directory-properties vec "") + (tramp-flush-connection-properties vec)) (tramp-set-connection-property vec "smbclient-version" tramp-smb-version))) @@ -1919,11 +1900,11 @@ If ARGUMENT is non-nil, use it as argument for ;; connection timeout. (with-current-buffer buf (goto-char (point-min)) - (when (and (> (tramp-time-diff - (current-time) - (tramp-get-connection-property - p "last-cmd-time" '(0 0 0))) - 60) + ;; `seconds-to-time' can be removed once we get rid of Emacs 24. + (when (and (time-less-p (seconds-to-time 60) + (time-since + (tramp-get-connection-property + p "last-cmd-time" (seconds-to-time 0)))) (process-live-p p) (re-search-forward tramp-smb-errors nil t)) (delete-process p) @@ -1936,6 +1917,14 @@ If ARGUMENT is non-nil, use it as argument for share (tramp-get-connection-property p "smb-share" "")))) + ;; During completion, don't reopen a new connection. We + ;; check this for the process related to + ;; `tramp-buffer-name'; otherwise `start-file-process' + ;; wouldn't run ever when `non-essential' is non-nil. + (when (and (tramp-completion-mode-p) + (null (get-process (tramp-buffer-name vec)))) + (throw 'non-essential 'non-essential)) + (save-match-data ;; There might be unread output from checking for share names. (when buf (with-current-buffer buf (erase-buffer))) @@ -1984,19 +1973,11 @@ If ARGUMENT is non-nil, use it as argument for tramp-smb-winexe-program tramp-smb-program) args)))) - (tramp-message - vec 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" vec) - (process-put p 'adjust-window-size-function 'ignore) + (tramp-message vec 6 "%s" (string-join (process-command p) " ")) + (process-put p 'vector vec) + (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method tramp-smb-method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - (condition-case err (let (tramp-message-show-message) ;; Play login scenario. @@ -2007,20 +1988,22 @@ If ARGUMENT is non-nil, use it as argument for tramp-smb-actions-without-share)) ;; Check server version. - (unless argument - (with-current-buffer (tramp-get-connection-buffer vec) - (goto-char (point-min)) - (search-forward-regexp tramp-smb-server-version nil t) - (let ((smbserver-version (match-string 0))) - (unless - (string-equal - smbserver-version - (tramp-get-connection-property - vec "smbserver-version" smbserver-version)) - (tramp-flush-directory-property vec "") - (tramp-flush-connection-property vec)) - (tramp-set-connection-property - vec "smbserver-version" smbserver-version)))) + ;; FIXME: With recent smbclient versions, this + ;; information isn't printed anymore. + ;; (unless argument + ;; (with-current-buffer (tramp-get-connection-buffer vec) + ;; (goto-char (point-min)) + ;; (search-forward-regexp tramp-smb-server-version nil t) + ;; (let ((smbserver-version (match-string 0))) + ;; (unless + ;; (string-equal + ;; smbserver-version + ;; (tramp-get-connection-property + ;; vec "smbserver-version" smbserver-version)) + ;; (tramp-flush-directory-properties vec "") + ;; (tramp-flush-connection-properties vec)) + ;; (tramp-set-connection-property + ;; vec "smbserver-version" smbserver-version)))) ;; Set chunksize to 1. smbclient reads its input ;; character by character; if we send the string @@ -2056,51 +2039,27 @@ If ARGUMENT is non-nil, use it as argument for ;; We don't use timeouts. If needed, the caller shall wrap around. (defun tramp-smb-wait-for-output (vec) "Wait for output from smbclient command. -Returns nil if an error message has appeared." +Removes smb prompt. Returns nil if an error message has appeared." (with-current-buffer (tramp-get-connection-buffer vec) (let ((p (get-buffer-process (current-buffer))) - (found (progn (goto-char (point-min)) - (re-search-forward tramp-smb-prompt nil t))) - (err (progn (goto-char (point-min)) - (re-search-forward tramp-smb-errors nil t))) - buffer-read-only) - - ;; Algorithm: get waiting output. See if last line contains - ;; `tramp-smb-prompt' sentinel or `tramp-smb-errors' strings. - ;; If not, wait a bit and again get waiting output. - (while (and (not found) (not err) (process-live-p p)) - - ;; Accept pending output. - (tramp-accept-process-output p 0.1) - - ;; Search for prompt. - (goto-char (point-min)) - (setq found (re-search-forward tramp-smb-prompt nil t)) - - ;; Search for errors. - (goto-char (point-min)) - (setq err (re-search-forward tramp-smb-errors nil t))) - - ;; When the process is still alive, read pending output. - (while (and (not found) (process-live-p p)) - - ;; Accept pending output. - (tramp-accept-process-output p 0.1) - - ;; Search for prompt. - (goto-char (point-min)) - (setq found (re-search-forward tramp-smb-prompt nil t))) + (inhibit-read-only t)) + ;; Read pending output. + (while (not (re-search-forward tramp-smb-prompt nil t)) + (while (tramp-accept-process-output p 0)) + (goto-char (point-min))) (tramp-message vec 6 "\n%s" (buffer-string)) ;; Remove prompt. - (when found + (goto-char (point-min)) + (when (re-search-forward tramp-smb-prompt nil t) (goto-char (point-max)) (re-search-backward tramp-smb-prompt nil t) (delete-region (point) (point-max))) ;; Return value is whether no error message has appeared. - (not err)))) + (goto-char (point-min)) + (not (re-search-forward tramp-smb-errors nil t))))) (defun tramp-smb-kill-winexe-function () "Send SIGKILL to the winexe process." @@ -2111,7 +2070,6 @@ Returns nil if an error message has appeared." (defun tramp-smb-call-winexe (vec) "Apply a remote command, if possible, using `tramp-smb-winexe-program'." - ;; Check for program. (unless (executable-find tramp-smb-winexe-program) (tramp-error diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el new file mode 100644 index 00000000000..0ded85fb554 --- /dev/null +++ b/lisp/net/tramp-sudoedit.el @@ -0,0 +1,894 @@ +;;; tramp-sudoedit.el --- Functions for accessing under root permissions -*- lexical-binding:t -*- + +;; Copyright (C) 2018-2019 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; The "sudoedit" Tramp method allows to edit a file as a different +;; user on the local host. Contrary to the "sudo" method, all magic +;; file name functions are implemented by single "sudo ..." commands. +;; The purpose is to make editing such a file as secure as possible; +;; there must be no session running in the Emacs background which +;; could be attacked from inside Emacs. + +;; Consequently, external processes are not implemented. + +;;; Code: + +(require 'tramp) + +;;;###tramp-autoload +(defconst tramp-sudoedit-method "sudoedit" + "When this method name is used, call sudoedit for editing a file.") + +;;;###tramp-autoload +(tramp--with-startup + (add-to-list 'tramp-methods + `(,tramp-sudoedit-method + (tramp-sudo-login (("sudo") ("-u" "%u") ("-S") ("-H") + ("-p" "Password:") ("--"))))) + + (add-to-list 'tramp-default-user-alist '("\\`sudoedit\\'" nil "root")) + + (tramp-set-completion-function + tramp-sudoedit-method tramp-completion-function-alist-su)) + +(defconst tramp-sudoedit-sudo-actions + '((tramp-password-prompt-regexp tramp-action-password) + (tramp-wrong-passwd-regexp tramp-action-permission-denied) + (tramp-process-alive-regexp tramp-sudoedit-action-sudo)) + "List of pattern/action pairs. +This list is used for sudo calls. + +See `tramp-actions-before-shell' for more info.") + +;;;###tramp-autoload +(defconst tramp-sudoedit-file-name-handler-alist + '((access-file . tramp-handle-access-file) + (add-name-to-file . tramp-sudoedit-handle-add-name-to-file) + (byte-compiler-base-file-name . ignore) + ;; `copy-directory' performed by default handler. + (copy-file . tramp-sudoedit-handle-copy-file) + (delete-directory . tramp-sudoedit-handle-delete-directory) + (delete-file . tramp-sudoedit-handle-delete-file) + (diff-latest-backup-file . ignore) + ;; `directory-file-name' performed by default handler. + (directory-files . tramp-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-sudoedit-handle-expand-file-name) + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) + (file-acl . tramp-sudoedit-handle-file-acl) + (file-attributes . tramp-sudoedit-handle-file-attributes) + (file-directory-p . tramp-handle-file-directory-p) + (file-equal-p . tramp-handle-file-equal-p) + (file-executable-p . tramp-sudoedit-handle-file-executable-p) + (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-modes . tramp-handle-file-modes) + (file-name-all-completions + . tramp-sudoedit-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-sudoedit-handle-file-readable-p) + (file-regular-p . tramp-handle-file-regular-p) + (file-remote-p . tramp-handle-file-remote-p) + (file-selinux-context . tramp-sudoedit-handle-file-selinux-context) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-system-info . tramp-sudoedit-handle-file-system-info) + (file-truename . tramp-sudoedit-handle-file-truename) + (file-writable-p . tramp-sudoedit-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-handle-insert-file-contents) + (load . tramp-handle-load) + (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) + (make-directory . tramp-sudoedit-handle-make-directory) + (make-directory-internal . ignore) + (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-process . ignore) + (make-symbolic-link . tramp-sudoedit-handle-make-symbolic-link) + (process-file . ignore) + (rename-file . tramp-sudoedit-handle-rename-file) + (set-file-acl . tramp-sudoedit-handle-set-file-acl) + (set-file-modes . tramp-sudoedit-handle-set-file-modes) + (set-file-selinux-context . tramp-sudoedit-handle-set-file-selinux-context) + (set-file-times . tramp-sudoedit-handle-set-file-times) + (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-set-file-uid-gid . tramp-sudoedit-handle-set-file-uid-gid) + (unhandled-file-name-directory . ignore) + (vc-registered . ignore) + (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (write-region . tramp-sudoedit-handle-write-region)) + "Alist of handler functions for Tramp SUDOEDIT method.") + +;; 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-sudoedit-file-name-p (filename) + "Check if it's a filename for SUDOEDIT." + (and (tramp-tramp-file-p filename) + (string= (tramp-file-name-method (tramp-dissect-file-name filename)) + tramp-sudoedit-method))) + +;;;###tramp-autoload +(defun tramp-sudoedit-file-name-handler (operation &rest args) + "Invoke the SUDOEDIT handler for OPERATION. +First arg specifies the OPERATION, second arg is a list of arguments to +pass to the OPERATION." + (let ((fn (assoc operation tramp-sudoedit-file-name-handler-alist))) + (if fn + (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-sudoedit-file-name-p #'tramp-sudoedit-file-name-handler)) + + +;; File name primitives. + +(defun tramp-sudoedit-handle-add-name-to-file + (filename newname &optional ok-if-already-exists) + "Like `add-name-to-file' for Tramp files." + (unless (tramp-equal-remote filename newname) + (with-parsed-tramp-file-name + (if (tramp-tramp-file-p filename) filename newname) nil + (tramp-error + v 'file-error + "add-name-to-file: %s" + "only implemented for same method, same user, same host"))) + (with-parsed-tramp-file-name filename v1 + (with-parsed-tramp-file-name newname v2 + ;; Do the 'confirm if exists' thing. + (when (file-exists-p newname) + ;; What to do? + (if (or (null ok-if-already-exists) ; not allowed to exist + (and (numberp ok-if-already-exists) + (not (yes-or-no-p + (format + "File %s already exists; make it a link anyway? " + v2-localname))))) + (tramp-error v2 'file-already-exists newname) + (delete-file newname))) + (tramp-flush-file-properties v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname) + (unless + (tramp-sudoedit-send-command + v1 "ln" + (tramp-compat-file-name-unquote v1-localname) + (tramp-compat-file-name-unquote v2-localname)) + (tramp-error + v1 'file-error + "error with add-name-to-file, see buffer `%s' for details" + (buffer-name)))))) + +(defun tramp-sudoedit-do-copy-or-rename-file + (op filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Copy or rename a remote file. +OP must be `copy' or `rename' and indicates the operation to perform. +FILENAME specifies the file to copy or rename, NEWNAME is the name of +the new file (for copy) or the new name of the file (for rename). +OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already. +KEEP-DATE means to make sure that NEWNAME has the same timestamp +as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep +the uid and gid if both files are on the same host. +PRESERVE-EXTENDED-ATTRIBUTES activates selinux and acl commands. + +This function is invoked by `tramp-sudoedit-handle-copy-file' and +`tramp-sudoedit-handle-rename-file'. It is an error if OP is +neither of `copy' and `rename'. FILENAME and NEWNAME must be +absolute file names." + (unless (memq op '(copy rename)) + (error "Unknown operation `%s', must be `copy' or `rename'" op)) + + (setq filename (file-truename filename)) + (if (file-directory-p filename) + (progn + (copy-directory filename newname keep-date t) + (when (eq op 'rename) (delete-directory filename 'recursive))) + + (let ((t1 (tramp-sudoedit-file-name-p filename)) + (t2 (tramp-sudoedit-file-name-p newname)) + (file-times (tramp-compat-file-attribute-modification-time + (file-attributes filename))) + (file-modes (tramp-default-file-modes filename)) + (attributes (and preserve-extended-attributes + (apply #'file-extended-attributes (list filename)))) + (sudoedit-operation + (cond + ((and (eq op 'copy) preserve-uid-gid) '("cp" "-f" "-p")) + ((eq op 'copy) '("cp" "-f")) + ((eq op 'rename) '("mv" "-f")))) + (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) + + (with-parsed-tramp-file-name (if t1 filename newname) nil + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (if (or (and (file-remote-p filename) (not t1)) + (and (file-remote-p newname) (not t2))) + ;; We cannot copy or rename directly. + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (if (eq op 'copy) + (copy-file filename tmpfile t) + (rename-file filename tmpfile t)) + (rename-file tmpfile newname ok-if-already-exists)) + + ;; Direct action. + (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) + (unless (tramp-sudoedit-send-command + v sudoedit-operation + (tramp-compat-file-name-unquote + (tramp-compat-file-local-name filename)) + (tramp-compat-file-name-unquote + (tramp-compat-file-local-name newname))) + (tramp-error + v 'file-error + "Error %s `%s' `%s'" msg-operation filename newname)))) + + ;; When `newname' is local, we must change the ownership to + ;; the local user. + (unless (file-remote-p newname) + (tramp-set-file-uid-gid + (concat (file-remote-p filename) newname) + (tramp-get-local-uid 'integer) + (tramp-get-local-gid 'integer))) + + ;; Set the time and mode. Mask possible errors. + (when keep-date + (ignore-errors + (set-file-times newname file-times) + (set-file-modes newname file-modes))) + + ;; Handle `preserve-extended-attributes'. We ignore possible + ;; errors, because ACL strings could be incompatible. + (when attributes + (ignore-errors + (apply #'set-file-extended-attributes (list newname attributes)))) + + (when (and t1 (eq op 'rename)) + (with-parsed-tramp-file-name filename v1 + (tramp-flush-file-properties + v1 (file-name-directory v1-localname)) + (tramp-flush-file-properties v1 v1-localname))) + + (when t2 + (with-parsed-tramp-file-name newname v2 + (tramp-flush-file-properties + v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname))))))) + +(defun tramp-sudoedit-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)) + (setq newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-sudoedit-do-copy-or-rename-file + 'copy filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + (tramp-run-real-handler + #'copy-file + (list filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes)))) + +(defun tramp-sudoedit-handle-delete-directory + (directory &optional recursive trash) + "Like `delete-directory' for Tramp files." + (setq directory (expand-file-name directory)) + (with-parsed-tramp-file-name directory nil + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) + (unless + (tramp-sudoedit-send-command + v (or (and trash "trash") + (if recursive '("rm" "-rf") "rmdir")) + (tramp-compat-file-name-unquote localname)) + (tramp-error v 'file-error "Couldn't delete %s" directory)))) + +(defun tramp-sudoedit-handle-delete-file (filename &optional trash) + "Like `delete-file' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (unless + (tramp-sudoedit-send-command + v (if (and trash delete-by-moving-to-trash) "trash" "rm") + (tramp-compat-file-name-unquote localname)) + ;; Propagate the error. + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (tramp-error-with-buffer + nil v 'file-error "Couldn't delete %s" filename))))) + +(defun tramp-sudoedit-handle-expand-file-name (name &optional dir) + "Like `expand-file-name' for Tramp files. +If the localname part of the given file name starts with \"/../\" then +the result will be a local, non-Tramp, file name." + ;; If DIR is not given, use `default-directory' or "/". + (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))) + (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 + ;; but to the root home directory. + (when (zerop (length localname)) + (setq localname "~")) + (unless (file-name-absolute-p localname) + (setq localname (format "~%s/%s" user localname))) + (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + (let ((uname (match-string 1 localname)) + (fname (match-string 2 localname))) + (when (string-equal uname "~") + (setq uname (concat uname user))) + (setq localname (concat uname fname)))) + ;; Do normal `expand-file-name' (this does "~user/", "/./" and "/../"). + (tramp-make-tramp-file-name v (expand-file-name localname)))) + +(defun tramp-sudoedit-remote-acl-p (vec) + "Check, whether ACL is enabled on the remote host." + (with-tramp-connection-property (tramp-get-connection-process vec) "acl-p" + (zerop (tramp-call-process vec "getfacl" nil nil nil "/")))) + +(defun tramp-sudoedit-handle-file-acl (filename) + "Like `file-acl' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-acl" + (let ((result (and (tramp-sudoedit-remote-acl-p v) + (tramp-sudoedit-send-command-string + v "getfacl" "-acp" + (tramp-compat-file-name-unquote localname))))) + ;; The acl string must have a trailing \n, which is not + ;; provided by `tramp-sudoedit-send-command-string'. Add it. + (and (stringp result) (concat result "\n")))))) + +(defun tramp-sudoedit-handle-file-attributes (filename &optional id-format) + "Like `file-attributes' for Tramp files." + (unless id-format (setq id-format 'integer)) + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property + v localname (format "file-attributes-%s" id-format) + (tramp-message v 5 "file attributes: %s" localname) + (ignore-errors + (tramp-convert-file-attributes + v + (tramp-sudoedit-send-command-and-read + v "env" "QUOTING_STYLE=locale" "stat" "-c" + (format + ;; Apostrophes in the stat output are masked as + ;; `tramp-stat-marker', in order to make a proper shell + ;; escape of them in file names. + "((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)" + tramp-stat-marker tramp-stat-marker + (if (eq id-format 'integer) + "%u" + (eval-when-compile + (concat tramp-stat-marker "%U" tramp-stat-marker))) + (if (eq id-format 'integer) + "%g" + (eval-when-compile + (concat tramp-stat-marker "%G" tramp-stat-marker))) + tramp-stat-marker tramp-stat-marker) + (tramp-compat-file-name-unquote localname))))))) + +(defun tramp-sudoedit-handle-file-executable-p (filename) + "Like `file-executable-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-executable-p" + (tramp-sudoedit-send-command + v "test" "-x" (tramp-compat-file-name-unquote localname))))) + +(defun tramp-sudoedit-handle-file-exists-p (filename) + "Like `file-exists-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-exists-p" + (tramp-sudoedit-send-command + v "test" "-e" (tramp-compat-file-name-unquote localname))))) + +(defun tramp-sudoedit-handle-file-name-all-completions (filename directory) + "Like `file-name-all-completions' for Tramp files." + (all-completions + filename + (with-parsed-tramp-file-name (expand-file-name directory) nil + (with-tramp-file-property v localname "file-name-all-completions" + (tramp-sudoedit-send-command + v "ls" "-a1" "--quoting-style=literal" "--show-control-chars" + (if (zerop (length localname)) + "" (tramp-compat-file-name-unquote localname))) + (mapcar + (lambda (f) + (if (file-directory-p (expand-file-name f directory)) + (file-name-as-directory f) + f)) + (with-current-buffer (tramp-get-connection-buffer v) + (delq + nil + (mapcar + (lambda (l) (and (not (string-match-p "^[[:space:]]*$" l)) l)) + (split-string (buffer-string) "\n" 'omit))))))))) + +(defun tramp-sudoedit-handle-file-readable-p (filename) + "Like `file-readable-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-readable-p" + (tramp-sudoedit-send-command + v "test" "-r" (tramp-compat-file-name-unquote localname))))) + +(defun tramp-sudoedit-handle-set-file-modes (filename mode) + "Like `set-file-modes' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (unless (tramp-sudoedit-send-command + v "chmod" (format "%o" mode) + (tramp-compat-file-name-unquote localname)) + (tramp-error + v 'file-error "Error while changing file's mode %s" filename)))) + +(defun tramp-sudoedit-remote-selinux-p (vec) + "Check, whether SELINUX is enabled on the remote host." + (with-tramp-connection-property (tramp-get-connection-process vec) "selinux-p" + (zerop (tramp-call-process vec "selinuxenabled")))) + +(defun tramp-sudoedit-handle-file-selinux-context (filename) + "Like `file-selinux-context' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-selinux-context" + (let ((context '(nil nil nil nil)) + (regexp (eval-when-compile + (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):" + "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)")))) + (when (and (tramp-sudoedit-remote-selinux-p v) + (tramp-sudoedit-send-command + v "ls" "-d" "-Z" + (tramp-compat-file-name-unquote localname))) + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (when (re-search-forward regexp (point-at-eol) t) + (setq context (list (match-string 1) (match-string 2) + (match-string 3) (match-string 4)))))) + ;; Return the context. + context)))) + +(defun tramp-sudoedit-handle-file-system-info (filename) + "Like `file-system-info' for Tramp files." + (ignore-errors + (with-parsed-tramp-file-name (expand-file-name filename) nil + (tramp-message v 5 "file system info: %s" localname) + (when (tramp-sudoedit-send-command + v "df" "--block-size=1" "--output=size,used,avail" + (tramp-compat-file-name-unquote localname))) + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (forward-line) + (when (looking-at + (eval-when-compile + (concat "[[:space:]]*\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)"))) + (list (string-to-number (match-string 1)) + ;; The second value is the used size. We need the + ;; free size. + (- (string-to-number (match-string 1)) + (string-to-number (match-string 2))) + (string-to-number (match-string 3)))))))) + +(defun tramp-sudoedit-handle-set-file-times (filename &optional time) + "Like `set-file-times' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (let ((time + (if (or (null time) + (tramp-compat-time-equal-p time tramp-time-doesnt-exist) + (tramp-compat-time-equal-p time tramp-time-dont-know)) + (current-time) + time))) + (tramp-sudoedit-send-command + v "env" "TZ=UTC" "touch" "-t" + (format-time-string "%Y%m%d%H%M.%S" time t) + (tramp-compat-file-name-unquote localname))))) + +(defun tramp-sudoedit-handle-file-truename (filename) + "Like `file-truename' for Tramp files." + ;; Preserve trailing "/". + (funcall + (if (string-equal (file-name-nondirectory filename) "") + #'file-name-as-directory #'identity) + (with-parsed-tramp-file-name (expand-file-name filename) nil + (tramp-make-tramp-file-name + v + (with-tramp-file-property v localname "file-truename" + (let ((quoted (tramp-compat-file-name-quoted-p localname)) + (localname (tramp-compat-file-name-unquote localname)) + result) + (tramp-message v 4 "Finding true name for `%s'" filename) + (setq result (tramp-sudoedit-send-command-string + v "readlink" "--canonicalize-missing" localname)) + ;; Detect cycle. + (when (and (file-symlink-p filename) + (string-equal result localname)) + (tramp-error + v 'file-error + "Apparent cycle of symbolic links for %s" filename)) + ;; If the resulting localname looks remote, we must quote it + ;; for security reasons. + (when (or quoted (file-remote-p result)) + (let (file-name-handler-alist) + (setq result (tramp-compat-file-name-quote result)))) + (tramp-message v 4 "True name of `%s' is `%s'" localname result) + result)) + 'nohop)))) + +(defun tramp-sudoedit-handle-file-writable-p (filename) + "Like `file-writable-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-writable-p" + (if (file-exists-p filename) + (tramp-sudoedit-send-command + v "test" "-w" (tramp-compat-file-name-unquote localname)) + (let ((dir (file-name-directory filename))) + (and (file-exists-p dir) + (file-writable-p dir))))))) + +(defun tramp-sudoedit-handle-make-directory (dir &optional parents) + "Like `make-directory' for Tramp files." + (setq dir (expand-file-name dir)) + (with-parsed-tramp-file-name dir nil + ;; 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 cache. + (tramp-flush-directory-properties + v (if parents "/" (file-name-directory localname))) + (unless (tramp-sudoedit-send-command + v (if parents '("mkdir" "-p") "mkdir") + (tramp-compat-file-name-unquote localname)) + (tramp-error v 'file-error "Couldn't make directory %s" dir)))) + +(defun tramp-sudoedit-handle-make-symbolic-link + (target linkname &optional ok-if-already-exists) + "Like `make-symbolic-link' for Tramp files. +If TARGET is a non-Tramp file, it is used verbatim as the target +of the symlink. If TARGET is a Tramp file, only the localname +component is used as the target of the symlink." + (if (not (tramp-tramp-file-p (expand-file-name linkname))) + (tramp-run-real-handler + #'make-symbolic-link (list target linkname ok-if-already-exists)) + + (with-parsed-tramp-file-name linkname nil + ;; If TARGET is a Tramp name, use just the localname component. + ;; Don't check for a proper method. + (let ((non-essential t)) + (when (and (tramp-tramp-file-p target) + (tramp-file-name-equal-p v (tramp-dissect-file-name target))) + (setq target + (tramp-file-name-localname + (tramp-dissect-file-name (expand-file-name target)))))) + + ;; If TARGET is still remote, quote it. + (if (tramp-tramp-file-p target) + (make-symbolic-link + (let (file-name-handler-alist) (tramp-compat-file-name-quote target)) + linkname ok-if-already-exists) + + ;; Do the 'confirm if exists' thing. + (when (file-exists-p linkname) + ;; What to do? + (if (or (null ok-if-already-exists) ; not allowed to exist + (and (numberp ok-if-already-exists) + (not + (yes-or-no-p + (format + "File %s already exists; make it a link anyway? " + localname))))) + (tramp-error v 'file-already-exists localname) + (delete-file linkname))) + + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (tramp-sudoedit-send-command + v "ln" "-sf" + (tramp-compat-file-name-unquote target) + (tramp-compat-file-name-unquote localname)))))) + +(defun tramp-sudoedit-handle-rename-file + (filename newname &optional ok-if-already-exists) + "Like `rename-file' for Tramp files." + (setq filename (expand-file-name filename)) + (setq newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-sudoedit-do-copy-or-rename-file + '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)))) + +(defun tramp-sudoedit-handle-set-file-acl (filename acl-string) + "Like `set-file-acl' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (when (and (stringp acl-string) (tramp-sudoedit-remote-acl-p v)) + ;; Massage `acl-string'. + (setq acl-string (string-join (split-string acl-string "\n" 'omit) ",")) + (prog1 + (tramp-sudoedit-send-command + v "setfacl" "-m" + acl-string (tramp-compat-file-name-unquote localname)) + (tramp-flush-file-property v localname "file-acl"))))) + +(defun tramp-sudoedit-handle-set-file-selinux-context (filename context) + "Like `set-file-selinux-context' for Tramp files." + (with-parsed-tramp-file-name filename nil + (when (and (consp context) + (tramp-sudoedit-remote-selinux-p v)) + (let ((user (and (stringp (nth 0 context)) (nth 0 context))) + (role (and (stringp (nth 1 context)) (nth 1 context))) + (type (and (stringp (nth 2 context)) (nth 2 context))) + (range (and (stringp (nth 3 context)) (nth 3 context)))) + (when (tramp-sudoedit-send-command + v "chcon" + (when user (format "--user=%s" user)) + (when role (format "--role=%s" role)) + (when type (format "--type=%s" type)) + (when range (format "--range=%s" range)) + (tramp-compat-file-name-unquote localname)) + (if (and user role type range) + (tramp-set-file-property + v localname "file-selinux-context" context) + (tramp-flush-file-property v localname "file-selinux-context")) + t))))) + +(defun tramp-sudoedit-get-remote-uid (vec id-format) + "The uid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (with-tramp-connection-property vec (format "uid-%s" id-format) + (if (equal id-format 'integer) + (tramp-sudoedit-send-command-and-read vec "id" "-u") + (tramp-sudoedit-send-command-string vec "id" "-un")))) + +(defun tramp-sudoedit-get-remote-gid (vec id-format) + "The gid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (with-tramp-connection-property vec (format "gid-%s" id-format) + (if (equal id-format 'integer) + (tramp-sudoedit-send-command-and-read vec "id" "-g") + (tramp-sudoedit-send-command-string vec "id" "-gn")))) + +(defun tramp-sudoedit-handle-set-file-uid-gid (filename &optional uid gid) + "Like `tramp-set-file-uid-gid' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-sudoedit-send-command + v "chown" + (format "%d:%d" + (or uid (tramp-sudoedit-get-remote-uid v 'integer)) + (or gid (tramp-sudoedit-get-remote-gid v 'integer))) + (tramp-compat-file-name-unquote + (tramp-compat-file-local-name filename))))) + +(defun tramp-sudoedit-handle-write-region + (start end filename &optional append visit lockname mustbenew) + "Like `write-region' for Tramp files." + (with-parsed-tramp-file-name filename nil + (let ((uid (or (tramp-compat-file-attribute-user-id + (file-attributes filename 'integer)) + (tramp-sudoedit-get-remote-uid v 'integer))) + (gid (or (tramp-compat-file-attribute-group-id + (file-attributes filename 'integer)) + (tramp-sudoedit-get-remote-gid v 'integer))) + (modes (tramp-default-file-modes 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'. + (unless (and (= (tramp-compat-file-attribute-user-id + (file-attributes filename 'integer)) + uid) + (= (tramp-compat-file-attribute-group-id + (file-attributes filename 'integer)) + gid)) + (tramp-set-file-uid-gid filename uid gid)) + (set-file-modes filename modes))))) + + +;; Internal functions. + +;; Used in `tramp-sudoedit-sudo-actions'. +(defun tramp-sudoedit-action-sudo (proc vec) + "Check, whether a sudo process has finished. +Remove unneeded output." + ;; There might be pending output for the exit status. + (unless (process-live-p proc) + (while (tramp-accept-process-output proc 0)) + ;; Delete narrowed region, it would be in the way reading a Lisp form. + (goto-char (point-min)) + (widen) + (delete-region (point-min) (point)) + ;; Delete empty lines. + (goto-char (point-min)) + (while (and (not (eobp)) (= (point) (point-at-eol))) + (forward-line)) + (delete-region (point-min) (point)) + (tramp-message vec 3 "Process has finished.") + (throw 'tramp-action 'ok))) + +(defun tramp-sudoedit-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." + ;; We need a process bound to the connection buffer. Therefore, we + ;; create a dummy process. Maybe there is a better solution? + (unless (tramp-get-connection-process vec) + + ;; During completion, don't reopen a new connection. We check + ;; this for the process related to `tramp-buffer-name'; otherwise + ;; `start-file-process' wouldn't run ever when `non-essential' is + ;; non-nil. + (when (and (tramp-completion-mode-p) + (null (get-process (tramp-buffer-name vec)))) + (throw 'non-essential 'non-essential)) + + (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) + + ;; Mark it as connected. + (tramp-set-connection-property p "connected" t)) + + ;; In `tramp-check-cached-permissions', the connection properties + ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. + (tramp-sudoedit-get-remote-uid vec 'integer) + (tramp-sudoedit-get-remote-gid vec 'integer) + (tramp-sudoedit-get-remote-uid vec 'string) + (tramp-sudoedit-get-remote-gid vec 'string))) + +(defun tramp-sudoedit-send-command (vec &rest args) + "Send commands ARGS to connection VEC. +If an element of ARGS is a list, it will be flattened. If an +element of ARGS is nil, it will be deleted. +Erases temporary buffer before sending the command. Returns nil +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) + (process-connection-type tramp-process-connection-type) + (p (apply #'start-process + (tramp-get-connection-name vec) (current-buffer) 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. + auth-source-save-behavior) + (tramp-message vec 6 "%s" (string-join (process-command p) " ")) + ;; Avoid process status message in output buffer. + (set-process-sentinel p #'ignore) + (process-put p 'vector vec) + (process-put p 'adjust-window-size-function #'ignore) + (set-process-query-on-exit-flag p nil) + (tramp-process-actions p vec nil tramp-sudoedit-sudo-actions) + (tramp-message vec 6 "%s\n%s" (process-exit-status p) (buffer-string)) + (prog1 + (zerop (process-exit-status p)) + (delete-process p))))) + +(defun tramp-sudoedit-send-command-and-read (vec &rest args) + "Run command ARGS and return the output, which must be a Lisp expression. +In case there is no valid Lisp expression, it raises an error." + (when (apply #'tramp-sudoedit-send-command vec args) + (with-current-buffer (tramp-get-connection-buffer vec) + ;; Replace stat marker. + (goto-char (point-min)) + (when (search-forward tramp-stat-marker nil t) + (goto-char (point-min)) + (while (search-forward "\"" nil t) + (replace-match "\\\"" nil 'literal)) + (goto-char (point-min)) + (while (search-forward tramp-stat-marker nil t) + (replace-match "\""))) + ;; Read the expression. + (tramp-message vec 6 "\n%s" (buffer-string)) + (goto-char (point-min)) + (condition-case nil + (prog1 (read (current-buffer)) + ;; Error handling. + (when (re-search-forward "\\S-" (point-at-eol) t) + (error nil))) + (error (tramp-error + vec 'file-error + "`%s' does not return a valid Lisp expression: `%s'" + (car args) (buffer-string))))))) + +(defun tramp-sudoedit-send-command-string (vec &rest args) + "Run command ARGS and return the output as astring." + (when (apply #'tramp-sudoedit-send-command vec args) + (with-current-buffer (tramp-get-connection-buffer vec) + (tramp-message vec 6 "\n%s" (buffer-string)) + (goto-char (point-max)) + ;(delete-blank-lines) + (while (looking-back "[ \t\n]+" nil 'greedy) + (delete-region (match-beginning 0) (point))) + (when (> (point-max) (point-min)) + (substring-no-properties (buffer-string)))))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-sudoedit 'force))) + +(provide 'tramp-sudoedit) + +;;; TODO: + +;; * Fix *-selinux functions. Likely, this is due to wrong file +;; ownership after `write-region' and/or `copy-file'. + +;;; tramp-sudoedit.el ends here diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 315e7099479..717ced80f28 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -7,6 +7,9 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp +;; Version: 2.4.3-pre +;; Package-Requires: ((emacs "24.4")) +;; URL: https://savannah.gnu.org/projects/tramp ;; This file is part of GNU Emacs. @@ -35,8 +38,6 @@ ;; Notes: ;; ----- ;; -;; This package only works for Emacs 24.1 and higher. -;; ;; Also see the todo list at the bottom of this file. ;; ;; The current version of Tramp can be retrieved from the following URL: @@ -56,12 +57,13 @@ ;;; Code: (require 'tramp-compat) +(require 'tramp-integration) +(require 'trampver) ;; Pacify byte-compiler. (require 'cl-lib) +(declare-function netrc-parse "netrc") (defvar auto-save-file-name-transforms) -(defvar eshell-path-env) -(defvar ls-lisp-use-insert-directory-program) (defvar outline-regexp) ;;; User Customizable Internal Variables: @@ -73,6 +75,16 @@ :link '(custom-manual "(tramp)Top") :version "22.1") +(eval-and-compile ;; So it's also available in tramp-loaddefs.el! + (defvar tramp--startup-hook nil + "Forms to be executed at the end of tramp.el.") + + (defmacro tramp--with-startup (&rest body) + "Schedule BODY to be executed at the end of tramp.el." + `(add-hook 'tramp--startup-hook (lambda () ,@body)))) + +(require 'tramp-loaddefs) + ;; Maybe we need once a real Tramp mode, with key bindings etc. ;;;###autoload (defcustom tramp-mode t @@ -122,8 +134,10 @@ This setting has precedence over `auto-save-file-name-transforms'." :type '(choice (const :tag "Use default" nil) (directory :tag "Auto save directory name"))) +;; Suppress `shell-file-name' for w32 systems. (defcustom tramp-encoding-shell - (or (tramp-compat-funcall 'w32-shell-name) "/bin/sh") + (let (shell-file-name) + (or (tramp-compat-funcall 'w32-shell-name) "/bin/sh")) "Use this program for encoding and decoding commands on the local host. This shell is used to execute the encoding and decoding command on the local host, so if you want to use `~' in those commands, you should @@ -146,27 +160,31 @@ use for the remote host." :group 'tramp :type '(file :must-match t)) +;; Suppress `shell-file-name' for w32 systems. (defcustom tramp-encoding-command-switch - (if (tramp-compat-funcall 'w32-shell-dos-semantics) "/c" "-c") + (let (shell-file-name) + (if (tramp-compat-funcall 'w32-shell-dos-semantics) "/c" "-c")) "Use this switch together with `tramp-encoding-shell' for local commands. See the variable `tramp-encoding-shell' for more information." :group 'tramp :type 'string) +;; Suppress `shell-file-name' for w32 systems. (defcustom tramp-encoding-command-interactive - (unless (tramp-compat-funcall 'w32-shell-dos-semantics) "-i") + (let (shell-file-name) + (unless (tramp-compat-funcall 'w32-shell-dos-semantics) "-i")) "Use this switch together with `tramp-encoding-shell' for interactive shells. See the variable `tramp-encoding-shell' for more information." :version "24.1" :group 'tramp :type '(choice (const nil) string)) -;;;###tramp-autoload (defvar tramp-methods nil "Alist of methods for remote files. This is a list of entries of the form (NAME PARAM1 PARAM2 ...). Each NAME stands for a remote access method. Each PARAM is a pair of the form (KEY VALUE). The following KEYs are defined: + * `tramp-remote-shell' This specifies the shell to use on the remote host. This MUST be a Bourne-like shell. It is normally not necessary to @@ -175,19 +193,23 @@ pair of the form (KEY VALUE). The following KEYs are defined: for it. Also note that \"/bin/sh\" exists on all Unixen, this might not be true for the value that you decide to use. You Have Been Warned. + * `tramp-remote-shell-login' This specifies the arguments to let `tramp-remote-shell' run as a login shell. It defaults to (\"-l\"), but some shells, like ksh, require another argument. See `tramp-connection-properties' for a way to overwrite the default value. + * `tramp-remote-shell-args' For implementation of `shell-command', this specifies the arguments to let `tramp-remote-shell' run a single command. + * `tramp-login-program' This specifies the name of the program to use for logging in to the remote host. This may be the name of rsh or a workalike program, or the name of telnet or a workalike, or the name of su or a workalike. + * `tramp-login-args' This specifies the list of arguments to pass to the above mentioned program. Please note that this is a list of list of arguments, @@ -203,55 +225,88 @@ pair of the form (KEY VALUE). The following KEYs are defined: `tramp-make-tramp-temp-file'. \"%k\" indicates the keep-date parameter of a program, if exists. \"%c\" adds additional `tramp-ssh-controlmaster-options' options for the first hop. + The existence of `tramp-login-args', combined with the absence of + `tramp-copy-args', is an indication that the method is capable of + multi-hops. + * `tramp-login-env' A list of environment variables and their values, which will be set when calling `tramp-login-program'. + * `tramp-async-args' When an asynchronous process is started, we know already that the connection works. Therefore, we can pass additional parameters to suppress diagnostic messages, in order not to tamper the process output. + * `tramp-copy-program' This specifies the name of the program to use for remotely copying the file; this might be the absolute filename of scp or the name of a workalike program. It is always applied on the local host. + * `tramp-copy-args' This specifies the list of parameters to pass to the above mentioned program, the hints for `tramp-login-args' also apply here. + * `tramp-copy-env' A list of environment variables and their values, which will be set when calling `tramp-copy-program'. + * `tramp-remote-copy-program' The listener program to be applied on remote side, if needed. + * `tramp-remote-copy-args' The list of parameters to pass to the listener program, the hints for `tramp-login-args' also apply here. Additionally, \"%r\" could be used here and in `tramp-copy-args'. It denotes a randomly chosen port for the remote listener. + * `tramp-copy-keep-date' This specifies whether the copying program when the preserves the timestamp of the original file. + * `tramp-copy-keep-tmpfile' This specifies whether a temporary local file shall be kept for optimization reasons (useful for \"rsync\" methods). + * `tramp-copy-recursive' Whether the operation copies directories recursively. + * `tramp-default-port' The default port of a method. + * `tramp-tmpdir' A directory on the remote host for temporary files. If not specified, \"/tmp\" is taken as default. + * `tramp-connection-timeout' This is the maximum time to be spent for establishing a connection. In general, the global default value shall be used, but for some methods, like \"su\" or \"sudo\", a shorter timeout might be desirable. + + * `tramp-session-timeout' + How long a Tramp connection keeps open before being disconnected. + This is useful for methods like \"su\" or \"sudo\", which + shouldn't run an open connection in the background forever. + * `tramp-case-insensitive' Whether the remote file system handles file names case insensitive. Only a non-nil value counts, the default value nil means to perform further checks on the remote host. See `tramp-connection-properties' for a way to overwrite this. + * `tramp-mount-args' + * `tramp-copyto-args' + * `tramp-moveto-args' + * `tramp-about-args' + These parameters, a list of list like `tramp-login-args', are used + for the \"rclone\" method, and are appended to the respective + \"rclone\" commands. In general, they shouldn't be changed inside + `tramp-methods'; it is recommended to change their values via + `tramp-connection-properties'. Unlike `tramp-login-args' there is + no pattern replacement. + What does all this mean? Well, you should specify `tramp-login-program' for all methods; this program is used to log in to the remote site. Then, there are two ways to actually transfer the files between the local and the @@ -304,7 +359,6 @@ Also see `tramp-default-method-alist'." :group 'tramp :type 'string) -;;;###tramp-autoload (defcustom tramp-default-method-alist nil "Default method to use for specific host/user pairs. This is an alist of items (HOST USER METHOD). The first matching item @@ -334,7 +388,6 @@ This variable is regarded as obsolete, and will be removed soon." :group 'tramp :type '(choice (const nil) string)) -;;;###tramp-autoload (defcustom tramp-default-user-alist nil "Default user to use for specific method/host pairs. This is an alist of items (METHOD HOST USER). The first matching item @@ -356,7 +409,6 @@ Useful for su and sudo methods mostly." :group 'tramp :type 'string) -;;;###tramp-autoload (defcustom tramp-default-host-alist nil "Default host to use for specific method/user pairs. This is an alist of items (METHOD USER HOST). The first matching item @@ -378,11 +430,17 @@ empty string for the method name." 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 a remote target matching USER@HOST. HOST and USER are regular -expressions. PROXY must be a Tramp filename without a localname -part. Method and user name on PROXY are optional, which is -interpreted with the default values. PROXY can contain the -patterns %h and %u, which are replaced by the strings matching -HOST or USER, respectively. +expressions, which could also cover a domain (USER%DOMAIN) or +port (HOST#PORT). PROXY must be a Tramp filename without a +localname part. Method and user name on PROXY are optional, +which is interpreted with the default values. + +PROXY can contain the patterns %h and %u, which are replaced by +the strings matching HOST or USER (without DOMAIN and PORT parts), +respectively. + +If an entry is added while parsing ad-hoc hop definitions, PROXY +carries the non-nil text property `tramp-ad-hoc'. HOST, USER or PROXY could also be Lisp forms, which will be evaluated. The result must be a string or nil, which is @@ -410,14 +468,18 @@ host runs a registered shell, it shall be added to this list, too." :group 'tramp :type '(repeat (regexp :tag "Host regexp"))) -;;;###tramp-autoload -(defconst tramp-local-host-regexp +(defcustom tramp-local-host-regexp (concat "\\`" (regexp-opt (list "localhost" "localhost6" (system-name) "127.0.0.1" "::1") t) "\\'") - "Host names which are regarded as local host.") + "Host names which are regarded as local host. +If the local host runs a chrooted environment, set this to nil." + :version "27.1" + :group 'tramp + :type '(choice (const :tag "Chrooted environment" nil) + (regexp :tag "Host regexp"))) (defvar tramp-completion-function-alist nil "Alist of methods for remote files. @@ -510,10 +572,7 @@ This regexp must match both `tramp-initial-end-of-output' and :type 'regexp) (defcustom tramp-password-prompt-regexp - (format "^.*\\(%s\\).*:\^@? *" - ;; `password-word-equivalents' has been introduced with Emacs 24.4. - (regexp-opt (or (bound-and-true-p password-word-equivalents) - '("password" "passphrase")))) + (format "^.*\\(%s\\).*:\^@? *" (regexp-opt password-word-equivalents)) "Regexp matching password-like prompts. The regexp should match at end of buffer. @@ -549,7 +608,10 @@ The regexp should match at end of buffer." (defcustom tramp-yesno-prompt-regexp (concat - (regexp-opt '("Are you sure you want to continue connecting (yes/no)?") t) + (regexp-opt + '("Are you sure you want to continue connecting (yes/no)?" + "Are you sure you want to continue connecting (yes/no/[fingerprint])?") + t) "\\s-*") "Regular expression matching all yes/no queries which need to be confirmed. The confirmation should be done with yes or no. @@ -632,7 +694,6 @@ Useful for \"rsync\" like methods.") (make-variable-buffer-local 'tramp-temp-buffer-file-name) (put 'tramp-temp-buffer-file-name 'permanent-local t) -;;;###tramp-autoload (defcustom tramp-syntax 'default "Tramp filename syntax to be used. @@ -651,8 +712,8 @@ Customize. See also `tramp-change-syntax'." (const :tag "Ange-FTP" simplified) (const :tag "XEmacs" separate)) :require 'tramp - :initialize 'custom-initialize-set - :set 'tramp-set-syntax) + :initialize #'custom-initialize-default + :set #'tramp-set-syntax) (defun tramp-set-syntax (symbol value) "Set SYMBOL to value VALUE. @@ -660,7 +721,7 @@ Used in user option `tramp-syntax'. There are further variables to be set, depending on VALUE." ;; Check allowed values. (unless (memq value (tramp-syntax-values)) - (tramp-compat-user-error "Wrong `tramp-syntax' %s" tramp-syntax)) + (tramp-user-error "Wrong `tramp-syntax' %s" value)) ;; Cleanup existing buffers. (unless (eq (symbol-value symbol) value) (tramp-cleanup-all-buffers)) @@ -692,14 +753,15 @@ to be set, depending on VALUE." ;; value of `tramp-file-name-regexp'. Other Tramp syntax variables ;; must be initialized as well to proper values. We do not call ;; `custom-set-variable', this would load Tramp via custom.el. -(eval-after-load 'tramp - '(tramp-set-syntax 'tramp-syntax (tramp-compat-tramp-syntax))) +(tramp--with-startup + (tramp-set-syntax 'tramp-syntax (tramp-compat-tramp-syntax))) (defun tramp-syntax-values () "Return possible values of `tramp-syntax', a list" (let ((values (cdr (get 'tramp-syntax 'custom-type)))) - (setq values (mapcar 'last values) - values (mapcar 'car values)))) + (setq values (mapcar #'last values) + values (mapcar #'car values)) + values)) (defun tramp-lookup-syntax (alist) "Look up a syntax string in ALIST according to `tramp-compat-tramp-syntax.' @@ -716,14 +778,14 @@ Raise an error if `tramp-syntax' is invalid." (defun tramp-build-prefix-format () (tramp-lookup-syntax tramp-prefix-format-alist)) -(defvar tramp-prefix-format (tramp-build-prefix-format) +(defvar tramp-prefix-format nil ;Initialized when defining `tramp-syntax'! "String matching the very beginning of Tramp file names. Used in `tramp-make-tramp-file-name'.") (defun tramp-build-prefix-regexp () (concat "^" (regexp-quote tramp-prefix-format))) -(defvar tramp-prefix-regexp (tramp-build-prefix-regexp) +(defvar tramp-prefix-regexp nil ;Initialized when defining `tramp-syntax'! "Regexp matching the very beginning of Tramp file names. Should always start with \"^\". Derived from `tramp-prefix-format'.") @@ -736,7 +798,7 @@ Should always start with \"^\". Derived from `tramp-prefix-format'.") (defun tramp-build-method-regexp () (tramp-lookup-syntax tramp-method-regexp-alist)) -(defvar tramp-method-regexp (tramp-build-method-regexp) +(defvar tramp-method-regexp nil ;Initialized when defining `tramp-syntax'! "Regexp matching methods identifiers. The `ftp' syntax does not support methods.") @@ -749,7 +811,7 @@ The `ftp' syntax does not support methods.") (defun tramp-build-postfix-method-format () (tramp-lookup-syntax tramp-postfix-method-format-alist)) -(defvar tramp-postfix-method-format (tramp-build-postfix-method-format) +(defvar tramp-postfix-method-format nil ;Init'd when defining `tramp-syntax'! "String matching delimiter between method and user or host names. The `ftp' syntax does not support methods. Used in `tramp-make-tramp-file-name'.") @@ -757,18 +819,16 @@ Used in `tramp-make-tramp-file-name'.") (defun tramp-build-postfix-method-regexp () (regexp-quote tramp-postfix-method-format)) -(defvar tramp-postfix-method-regexp (tramp-build-postfix-method-regexp) +(defvar tramp-postfix-method-regexp nil ;Init'd when defining `tramp-syntax'! "Regexp matching delimiter between method and user or host names. Derived from `tramp-postfix-method-format'.") (defconst tramp-user-regexp "[^/|: \t]+" "Regexp matching user names.") -;;;###tramp-autoload (defconst tramp-prefix-domain-format "%" "String matching delimiter between user and domain names.") -;;;###tramp-autoload (defconst tramp-prefix-domain-regexp (regexp-quote tramp-prefix-domain-format) "Regexp matching delimiter between user and domain names. Derived from `tramp-prefix-domain-format'.") @@ -802,21 +862,21 @@ Derived from `tramp-postfix-user-format'.") (defun tramp-build-prefix-ipv6-format () (tramp-lookup-syntax tramp-prefix-ipv6-format-alist)) -(defvar tramp-prefix-ipv6-format (tramp-build-prefix-ipv6-format) +(defvar tramp-prefix-ipv6-format nil ;Initialized when defining `tramp-syntax'! "String matching left hand side of IPv6 addresses. Used in `tramp-make-tramp-file-name'.") (defun tramp-build-prefix-ipv6-regexp () (regexp-quote tramp-prefix-ipv6-format)) -(defvar tramp-prefix-ipv6-regexp (tramp-build-prefix-ipv6-regexp) +(defvar tramp-prefix-ipv6-regexp nil ;Initialized when defining `tramp-syntax'! "Regexp matching left hand side of IPv6 addresses. Derived from `tramp-prefix-ipv6-format'.") ;; The following regexp is a bit sloppy. But it shall serve our ;; purposes. It covers also IPv4 mapped IPv6 addresses, like in ;; "::ffff:192.168.0.1". -(defconst tramp-ipv6-regexp "\\(?:\\(?:[a-zA-Z0-9]+\\)?:\\)+[a-zA-Z0-9.]+" +(defconst tramp-ipv6-regexp "\\(?:[a-zA-Z0-9]*:\\)+[a-zA-Z0-9.]+" "Regexp matching IPv6 addresses.") (defconst tramp-postfix-ipv6-format-alist @@ -828,14 +888,14 @@ Derived from `tramp-prefix-ipv6-format'.") (defun tramp-build-postfix-ipv6-format () (tramp-lookup-syntax tramp-postfix-ipv6-format-alist)) -(defvar tramp-postfix-ipv6-format (tramp-build-postfix-ipv6-format) +(defvar tramp-postfix-ipv6-format nil ;Initialized when defining `tramp-syntax'! "String matching right hand side of IPv6 addresses. Used in `tramp-make-tramp-file-name'.") (defun tramp-build-postfix-ipv6-regexp () (regexp-quote tramp-postfix-ipv6-format)) -(defvar tramp-postfix-ipv6-regexp (tramp-build-postfix-ipv6-regexp) +(defvar tramp-postfix-ipv6-regexp nil ;Initialized when defining `tramp-syntax'! "Regexp matching right hand side of IPv6 addresses. Derived from `tramp-postfix-ipv6-format'.") @@ -871,18 +931,18 @@ Derived from `tramp-postfix-hop-format'.") (defun tramp-build-postfix-host-format () (tramp-lookup-syntax tramp-postfix-host-format-alist)) -(defvar tramp-postfix-host-format (tramp-build-postfix-host-format) +(defvar tramp-postfix-host-format nil ;Initialized when defining `tramp-syntax'! "String matching delimiter between host names and localnames. Used in `tramp-make-tramp-file-name'.") (defun tramp-build-postfix-host-regexp () (regexp-quote tramp-postfix-host-format)) -(defvar tramp-postfix-host-regexp (tramp-build-postfix-host-regexp) +(defvar tramp-postfix-host-regexp nil ;Initialized when defining `tramp-syntax'! "Regexp matching delimiter between host names and localnames. Derived from `tramp-postfix-host-format'.") -(defconst tramp-localname-regexp ".*$" +(defconst tramp-localname-regexp "[^\n\r]*\\'" "Regexp matching localnames.") (defconst tramp-unknown-id-string "UNKNOWN" @@ -905,7 +965,7 @@ It is expected, that `tramp-syntax' has the proper value." "\\(?:" tramp-prefix-port-regexp tramp-port-regexp "\\)?" "\\)?")) (defvar tramp-remote-file-name-spec-regexp - (tramp-build-remote-file-name-spec-regexp) + nil ;Initialized when defining `tramp-syntax'! "Regular expression matching a Tramp file name between prefix and postfix.") (defun tramp-build-file-name-structure () @@ -921,7 +981,7 @@ See `tramp-file-name-structure'." "\\(" tramp-localname-regexp "\\)") 5 6 7 8 1)) -(defvar tramp-file-name-structure (tramp-build-file-name-structure) +(defvar tramp-file-name-structure nil ;Initialized when defining `tramp-syntax'! "List of six elements (REGEXP METHOD USER HOST FILE HOP), detailing \ the Tramp file name structure. @@ -956,6 +1016,13 @@ This regexp should match Tramp file names but no other file names. When calling `tramp-register-file-name-handlers', the initial value is overwritten by the car of `tramp-file-name-structure'.") +;;;###autoload +(defcustom tramp-ignored-file-name-regexp nil + "Regular expression matching file names that are not under Tramp’s control." + :version "27.1" + :group 'tramp + :type '(choice (const nil) regexp)) + (defconst tramp-completion-file-name-regexp-default (concat "\\`/\\(" @@ -1007,7 +1074,7 @@ See `tramp-file-name-structure' for more explanations.") (tramp-lookup-syntax tramp-completion-file-name-regexp-alist)) (defvar tramp-completion-file-name-regexp - (tramp-build-completion-file-name-regexp) + nil ;Initialized when defining `tramp-syntax'! "Regular expression matching file names handled by Tramp completion. This regexp should match partial Tramp file names only. @@ -1149,23 +1216,15 @@ means to use always cached values for the directory contents." ;;; Internal Variables: -(defvar tramp-current-method nil - "Connection method for this *tramp* buffer.") - -(defvar tramp-current-user nil - "Remote login name for this *tramp* buffer.") - -(defvar tramp-current-domain nil - "Remote domain name for this *tramp* buffer.") - -(defvar tramp-current-host nil - "Remote host for this *tramp* buffer.") - -(defvar tramp-current-port nil - "Remote port for this *tramp* buffer.") - (defvar tramp-current-connection nil - "Last connection timestamp.") + "Last connection timestamp. +It is a cons cell of the actual `tramp-file-name-structure', and +the (optional) timestamp of last activity on this connection.") + +(defvar tramp-password-save-function nil + "Password save function. +Will be called once the password has been verified by successful +authentication.") (defconst tramp-completion-file-name-handler-alist '((file-name-all-completions @@ -1177,7 +1236,6 @@ Operations not mentioned here will be handled by Tramp's file name handler functions, or the normal Emacs functions.") ;; Handlers for foreign methods, like FTP or SMB, shall be plugged here. -;;;###tramp-autoload (defvar tramp-foreign-file-name-handler-alist nil "Alist of elements (FUNCTION . HANDLER) for foreign methods handled specially. If (FUNCTION FILENAME) returns non-nil, then all I/O on that file is done by @@ -1216,6 +1274,7 @@ If nil, return `tramp-default-port'." (or (tramp-file-name-port vec) (tramp-get-method-parameter vec 'tramp-default-port))) +;; Comparision of file names is performed by `tramp-equal-remote'. (defun tramp-file-name-equal-p (vec1 vec2) "Check, whether VEC1 and VEC2 denote the same `tramp-file-name'." (and (tramp-file-name-p vec1) (tramp-file-name-p vec2) @@ -1246,22 +1305,24 @@ entry does not exist, return nil." "Return unquoted localname component of VEC." (tramp-compat-file-name-unquote (tramp-file-name-localname vec))) -;;;###tramp-autoload (defun tramp-tramp-file-p (name) "Return t if NAME is a string with Tramp file name syntax." - (and (stringp name) + (and tramp-mode (stringp name) ;; No "/:" and "/c:". This is not covered by `tramp-file-name-regexp'. (not (string-match-p (if (memq system-type '(cygwin windows-nt)) "^/[[:alpha:]]?:" "^/:") name)) + ;; Excluded file names. + (or (null tramp-ignored-file-name-regexp) + (not (string-match-p tramp-ignored-file-name-regexp name))) (string-match-p tramp-file-name-regexp name) t)) (defun tramp-find-method (method user host) "Return the right method string to use. This is METHOD, if non-nil. Otherwise, do a lookup in -`tramp-default-method-alist'." +`tramp-default-method-alist' and `tramp-default-method'." (when (and method (or (string-equal method "") (string-equal method tramp-default-method-marker))) @@ -1272,8 +1333,8 @@ This is METHOD, if non-nil. Otherwise, do a lookup in lmethod item) (while choices (setq item (pop choices)) - (when (and (string-match (or (nth 0 item) "") (or host "")) - (string-match (or (nth 1 item) "") (or user ""))) + (when (and (string-match-p (or (nth 0 item) "") (or host "")) + (string-match-p (or (nth 1 item) "") (or user ""))) (setq lmethod (nth 2 item)) (setq choices nil))) lmethod) @@ -1286,15 +1347,15 @@ This is METHOD, if non-nil. Otherwise, do a lookup in (defun tramp-find-user (method user host) "Return the right user string to use. This is USER, if non-nil. Otherwise, do a lookup in -`tramp-default-user-alist'." +`tramp-default-user-alist' and `tramp-default-user'." (let ((result (or user (let ((choices tramp-default-user-alist) luser item) (while choices (setq item (pop choices)) - (when (and (string-match (or (nth 0 item) "") (or method "")) - (string-match (or (nth 1 item) "") (or host ""))) + (when (and (string-match-p (or (nth 0 item) "") (or method "")) + (string-match-p (or (nth 1 item) "") (or host ""))) (setq luser (nth 2 item)) (setq choices nil))) luser) @@ -1306,18 +1367,24 @@ This is USER, if non-nil. Otherwise, do a lookup in (defun tramp-find-host (method user host) "Return the right host string to use. -This is HOST, if non-nil. Otherwise, it is `tramp-default-host'." - (or (and (> (length host) 0) host) - (let ((choices tramp-default-host-alist) - lhost item) - (while choices - (setq item (pop choices)) - (when (and (string-match (or (nth 0 item) "") (or method "")) - (string-match (or (nth 1 item) "") (or user ""))) - (setq lhost (nth 2 item)) - (setq choices nil))) - lhost) - tramp-default-host)) +This is HOST, if non-nil. Otherwise, do a lookup in +`tramp-default-host-alist' and `tramp-default-host'." + (let ((result + (or (and (> (length host) 0) host) + (let ((choices tramp-default-host-alist) + lhost item) + (while choices + (setq item (pop choices)) + (when (and (string-match-p (or (nth 0 item) "") (or method "")) + (string-match-p (or (nth 1 item) "") (or user ""))) + (setq lhost (nth 2 item)) + (setq choices nil))) + lhost) + tramp-default-host))) + ;; We must mark, whether a default value has been used. + (if (or (> (length host) 0) (null result)) + result + (propertize result 'tramp-default t)))) (defun tramp-dissect-file-name (name &optional nodefault) "Return a `tramp-file-name' structure of NAME, a remote file name. @@ -1329,7 +1396,7 @@ to their default values. For the other file name parts, no default values are used." (save-match-data (unless (tramp-tramp-file-p name) - (tramp-compat-user-error nil "Not a Tramp file name: \"%s\"" name)) + (tramp-user-error nil "Not a Tramp file name: \"%s\"" name)) (if (not (string-match (nth 0 tramp-file-name-structure) name)) (error "`tramp-file-name-structure' didn't match!") (let ((method (match-string (nth 1 tramp-file-name-structure) name)) @@ -1337,7 +1404,7 @@ default values are used." (host (match-string (nth 3 tramp-file-name-structure) name)) (localname (match-string (nth 4 tramp-file-name-structure) name)) (hop (match-string (nth 5 tramp-file-name-structure) name)) - domain port) + domain port v) (when user (when (string-match tramp-user-with-domain-regexp user) (setq domain (match-string 2 user) @@ -1353,13 +1420,56 @@ default values are used." (setq host (replace-match "" nil t host)))) (unless nodefault - (setq method (tramp-find-method method user host) - user (tramp-find-user method user host) - host (tramp-find-host method user host))) - - (make-tramp-file-name - :method method :user user :domain domain :host host :port port - :localname (or localname "") :hop hop))))) + (when hop + (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))) + (tramp-file-name-host v)) + tramp-default-host))) + (setq method (tramp-find-method method user host) + user (tramp-find-user method user host) + host (tramp-find-host method user host) + hop + (and hop + (format-spec hop (format-spec-make ?h host ?u user)))))) + + ;; Return result. + (prog1 + (setq v (make-tramp-file-name + :method method :user user :domain domain :host host + :port port :localname localname :hop hop)) + ;; The method must be known. + (unless (or (tramp-completion-mode-p) + (string-equal method tramp-default-method-marker) + (assoc method tramp-methods)) + (tramp-user-error + v "Method `%s' is not known." method)) + ;; Only some methods from tramp-sh.el do support multi-hops. + (when (and + hop + (or (not (tramp-get-method-parameter v 'tramp-login-program)) + (tramp-get-method-parameter v 'tramp-copy-program))) + (tramp-user-error + v "Method `%s' is not supported for multi-hops." method))))))) + +(defun tramp-dissect-hop-name (name &optional nodefault) + "Return a `tramp-file-name' structure of `hop' part of NAME. +See `tramp-dissect-file-name' for details." + (let ((v (tramp-dissect-file-name + (concat tramp-prefix-format + (replace-regexp-in-string + (concat tramp-postfix-hop-regexp "$") + tramp-postfix-host-format name)) + nodefault))) + ;; Only some methods from tramp-sh.el do support multi-hops. + (when (or (not (tramp-get-method-parameter v 'tramp-login-program)) + (tramp-get-method-parameter v 'tramp-copy-program)) + (tramp-user-error + v "Method `%s' is not supported for multi-hops." + (tramp-file-name-method v))) + ;; Return result. + v)) (defun tramp-buffer-name (vec) "A name for the connection buffer VEC." @@ -1370,33 +1480,75 @@ default values are used." (format "*tramp/%s %s@%s*" method user-domain host-port) (format "*tramp/%s %s*" method host-port)))) -(defun tramp-make-tramp-file-name - (method user domain host port localname &optional hop) - "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME. -When not nil, optional DOMAIN, PORT and HOP are used." - ;; Unless `tramp-syntax' is `simplified', we need a method. - (when (and (not (zerop (length tramp-postfix-method-format))) - (zerop (length method))) - (signal 'wrong-type-argument (list 'stringp method))) - (concat tramp-prefix-format hop - (unless (zerop (length tramp-postfix-method-format)) - (concat method tramp-postfix-method-format)) - user - (unless (zerop (length domain)) - (concat tramp-prefix-domain-format domain)) - (unless (zerop (length user)) - tramp-postfix-user-format) - (when host - (if (string-match tramp-ipv6-regexp host) - (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) - host)) - (unless (zerop (length port)) - (concat tramp-prefix-port-format port)) - tramp-postfix-host-format - (when localname localname))) +(defun tramp-make-tramp-file-name (&rest args) + "Construct a Tramp file name from ARGS. + +ARGS could have two different signatures. The first one is of +type (VEC &optional LOCALNAME HOP). +If LOCALNAME is nil, the value in VEC is used. If it is a +symbol, a null localname will be used. Otherwise, LOCALNAME is +expected to be a string, which will be used. +If HOP is nil, the value in VEC is used. If it is a symbol, a +null hop will be used. Otherwise, HOP is expected to be a +string, which will be used. + +The other signature exists for backward compatibility. It has +the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." + (let (method user domain host port localname hop) + (cond + ((tramp-file-name-p (car args)) + (setq method (tramp-file-name-method (car args)) + user (tramp-file-name-user (car args)) + domain (tramp-file-name-domain (car args)) + host (tramp-file-name-host (car args)) + port (tramp-file-name-port (car args)) + localname (tramp-file-name-localname (car args)) + hop (tramp-file-name-hop (car args))) + (when (cadr args) + (setq localname (and (stringp (cadr args)) (cadr args)))) + (when (cl-caddr args) + (setq hop (and (stringp (cl-caddr args)) (cl-caddr args))))) + + (t (setq method (nth 0 args) + user (nth 1 args) + domain (nth 2 args) + host (nth 3 args) + port (nth 4 args) + localname (nth 5 args) + hop (nth 6 args)))) + + ;; Unless `tramp-syntax' is `simplified', we need a method. + (when (and (not (zerop (length tramp-postfix-method-format))) + (zerop (length method))) + (signal 'wrong-type-argument (list #'stringp method))) + (concat tramp-prefix-format hop + (unless (zerop (length tramp-postfix-method-format)) + (concat method tramp-postfix-method-format)) + user + (unless (zerop (length domain)) + (concat tramp-prefix-domain-format domain)) + (unless (zerop (length user)) + tramp-postfix-user-format) + (when host + (if (string-match-p tramp-ipv6-regexp host) + (concat + tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) + host)) + (unless (zerop (length port)) + (concat tramp-prefix-port-format port)) + tramp-postfix-host-format + localname))) + +(defun tramp-make-tramp-hop-name (vec) + "Construct a Tramp hop name from VEC." + (replace-regexp-in-string + tramp-prefix-regexp "" + (replace-regexp-in-string + (concat tramp-postfix-host-regexp "$") tramp-postfix-hop-format + (tramp-make-tramp-file-name vec 'noloc)))) (defun tramp-completion-make-tramp-file-name (method user host localname) - "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME. + "Construct a Tramp file name from METHOD, USER, HOST and LOCALNAME. It must not be a complete Tramp file name, but as long as there are necessary only. This function will be used in file name completion." (concat tramp-prefix-format @@ -1407,7 +1559,7 @@ necessary only. This function will be used in file name completion." (concat user tramp-postfix-user-format)) (unless (zerop (length host)) (concat - (if (string-match tramp-ipv6-regexp host) + (if (string-match-p tramp-ipv6-regexp host) (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) host) @@ -1423,15 +1575,8 @@ necessary only. This function will be used in file name completion." (tramp-set-connection-property vec "process-buffer" (tramp-get-connection-property vec "process-buffer" nil)) - (setq buffer-undo-list t) - (setq default-directory - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - "/")) + (setq buffer-undo-list t + default-directory (tramp-make-tramp-file-name vec 'noloc 'nohop)) (current-buffer)))) (defun tramp-get-connection-buffer (vec) @@ -1506,8 +1651,6 @@ The outline level is equal to the verbosity of the Tramp message." (get-buffer-create (tramp-debug-buffer-name vec)) (when (bobp) (setq buffer-undo-list t) - ;; So it does not get loaded while `outline-regexp' is let-bound. - (require 'outline) ;; Activate `outline-mode'. This runs `text-mode-hook' and ;; `outline-mode-hook'. We must prevent that local processes ;; die. Yes: I've seen `flyspell-mode', which starts "ispell". @@ -1517,7 +1660,9 @@ The outline level is equal to the verbosity of the Tramp message." (outline-regexp tramp-debug-outline-regexp)) (outline-mode)) (set (make-local-variable 'outline-regexp) tramp-debug-outline-regexp) - (set (make-local-variable 'outline-level) 'tramp-debug-outline-level)) + (set (make-local-variable 'outline-level) 'tramp-debug-outline-level) + ;; Do not edit the debug buffer. + (use-local-map special-mode-map)) (current-buffer))) (defsubst tramp-debug-message (vec fmt-string &rest arguments) @@ -1533,10 +1678,13 @@ ARGUMENTS to actually emit the message (if applicable)." ";; Emacs: %s Tramp: %s -*- mode: outline; -*-" emacs-version tramp-version)) (when (>= tramp-verbose 10) - (insert - (format - "\n;; Location: %s Git: %s" - (locate-library "tramp") (tramp-repository-get-version))))) + (let ((tramp-verbose 0)) + (insert + (format + "\n;; Location: %s Git: %s/%s" + (locate-library "tramp") + (or tramp-repository-branch "") + (or tramp-repository-version "")))))) (unless (bolp) (insert "\n")) ;; Timestamp. @@ -1554,22 +1702,23 @@ ARGUMENTS to actually emit the message (if applicable)." (setq fn (symbol-name btf)) (unless (and - (string-match "^tramp" fn) + (string-match-p "^tramp" fn) (not - (string-match - (concat - "^" - (regexp-opt - '("tramp-backtrace" - "tramp-compat-funcall" - "tramp-compat-user-error" - "tramp-condition-case-unless-debug" - "tramp-debug-message" - "tramp-error" - "tramp-error-with-buffer" - "tramp-message") - t) - "$") + (string-match-p + (eval-when-compile + (concat + "^" + (regexp-opt + '("tramp-backtrace" + "tramp-compat-funcall" + "tramp-debug-message" + "tramp-error" + "tramp-error-with-buffer" + "tramp-message" + "tramp-signal-hook-function" + "tramp-user-error") + t) + "$")) fn))) (setq fn nil))) (setq btn (1+ btn)))) @@ -1607,54 +1756,54 @@ control string and the remaining ARGUMENTS to actually emit the message (if applicable)." (ignore-errors (when (<= level tramp-verbose) - ;; Match data must be preserved! - (save-match-data - ;; Display only when there is a minimum level. - (when (and tramp-message-show-message (<= level 3)) - (apply 'message - (concat - (cond - ((= level 0) "") - ((= level 1) "") - ((= level 2) "Warning: ") - (t "Tramp: ")) - fmt-string) - arguments)) - ;; Log only when there is a minimum level. - (when (>= tramp-verbose 4) - ;; Translate proc to vec. - (when (processp vec-or-proc) - (let ((tramp-verbose 0)) - (setq vec-or-proc - (tramp-get-connection-property vec-or-proc "vector" nil)))) + ;; Display only when there is a minimum level. + (when (and tramp-message-show-message (<= level 3)) + (apply #'message + (concat + (cond + ((= level 0) "") + ((= level 1) "") + ((= level 2) "Warning: ") + (t "Tramp: ")) + fmt-string) + arguments)) + ;; Log only when there is a minimum level. + (when (>= tramp-verbose 4) + (let ((tramp-verbose 0)) ;; Append connection buffer for error messages. (when (= level 1) - (let ((tramp-verbose 0)) - (with-current-buffer (tramp-get-connection-buffer vec-or-proc) - (setq fmt-string (concat fmt-string "\n%s") - arguments (append arguments (list (buffer-string))))))) - ;; Do it. - (when (tramp-file-name-p vec-or-proc) - (apply 'tramp-debug-message - vec-or-proc - (concat (format "(%d) # " level) fmt-string) - arguments))))))) + (with-current-buffer + (if (processp vec-or-proc) + (process-buffer vec-or-proc) + (tramp-get-connection-buffer vec-or-proc)) + (setq fmt-string (concat fmt-string "\n%s") + arguments (append arguments (list (buffer-string)))))) + ;; Translate proc to vec. + (when (processp vec-or-proc) + (setq vec-or-proc (process-get vec-or-proc 'vector)))) + ;; Do it. + (when (tramp-file-name-p vec-or-proc) + (apply #'tramp-debug-message + vec-or-proc + (concat (format "(%d) # " level) fmt-string) + arguments)))))) (defsubst tramp-backtrace (&optional vec-or-proc) "Dump a backtrace into the debug buffer. If VEC-OR-PROC is nil, the buffer *debug tramp* is used. This function is meant for debugging purposes." - (if vec-or-proc - (tramp-message vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))) - (if (>= tramp-verbose 10) - (with-output-to-temp-buffer "*debug tramp*" (backtrace))))) + (when (>= tramp-verbose 10) + (if vec-or-proc + (tramp-message + vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))) + (with-output-to-temp-buffer "*debug tramp*" (backtrace))))) (defsubst tramp-error (vec-or-proc signal fmt-string &rest arguments) "Emit an error. VEC-OR-PROC identifies the connection to use, SIGNAL is the signal identifier to be raised, remaining arguments passed to `tramp-message'. Finally, signal SIGNAL is raised." - (let (tramp-message-show-message) + (let (tramp-message-show-message signal-hook-function) (tramp-backtrace vec-or-proc) (unless arguments ;; FMT-STRING could be just a file name, as in @@ -1685,7 +1834,7 @@ an input event arrives. The other arguments are passed to `tramp-error'." (and buf (with-current-buffer buf (tramp-dissect-file-name default-directory)))))) (unwind-protect - (apply 'tramp-error vec-or-proc signal fmt-string arguments) + (apply #'tramp-error vec-or-proc signal fmt-string arguments) ;; Save exit. (when (and buf tramp-message-show-message @@ -1697,7 +1846,7 @@ an input event arrives. The other arguments are passed to `tramp-error'." (let ((enable-recursive-minibuffers t)) ;; `tramp-error' does not show messages. So we must do it ;; ourselves. - (apply 'message fmt-string arguments) + (apply #'message fmt-string arguments) ;; Show buffer. (pop-to-buffer buf) (discard-input) @@ -1706,6 +1855,28 @@ an input event arrives. The other arguments are passed to `tramp-error'." (when (tramp-file-name-equal-p vec (car tramp-current-connection)) (setcdr tramp-current-connection (current-time))))))) +;; We must make it a defun, because it is used earlier already. +(defun tramp-user-error (vec-or-proc fmt-string &rest arguments) + "Signal a user error (or \"pilot error\")." + (unwind-protect + (apply #'tramp-error vec-or-proc 'user-error fmt-string arguments) + ;; Save exit. + (when (and tramp-message-show-message + (not (zerop tramp-verbose)) + ;; Do not show when flagged from outside. + (not (tramp-completion-mode-p)) + ;; Show only when Emacs has started already. + (current-message)) + (let ((enable-recursive-minibuffers t)) + ;; `tramp-error' does not show messages. So we must do it ourselves. + (apply #'message fmt-string arguments) + (discard-input) + (sit-for 30) + ;; Reset timestamp. It would be wrong after waiting for a while. + (when + (tramp-file-name-equal-p vec-or-proc (car tramp-current-connection)) + (setcdr tramp-current-connection (current-time))))))) + (defmacro tramp-with-demoted-errors (vec-or-proc format &rest body) "Execute BODY while redirecting the error message to `tramp-message'. BODY is executed like wrapped by `with-demoted-errors'. FORMAT @@ -1718,6 +1889,12 @@ the resulting error message." (progn ,@body) (error (tramp-message ,vec-or-proc 3 ,format ,err) nil)))) +;; This function provides traces in case of errors not triggered by +;; Tramp functions. +(defun tramp-signal-hook-function (error-symbol data) + "Funtion to be called via `signal-hook-function'." + (tramp-error (car tramp-current-connection) error-symbol "%s" data)) + (defmacro with-parsed-tramp-file-name (filename var &rest body) "Parse a Tramp filename and make components available in the body. @@ -1752,12 +1929,12 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', (put 'with-parsed-tramp-file-name 'edebug-form-spec '(form symbolp body)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>")) -(defun tramp-progress-reporter-update (reporter &optional value) +(defun tramp-progress-reporter-update (reporter &optional value suffix) "Report progress of an operation for Tramp." (let* ((parameters (cdr reporter)) (message (aref parameters 3))) - (when (string-match message (or (current-message) "")) - (progress-reporter-update reporter value)))) + (when (string-match-p message (or (current-message) "")) + (tramp-compat-progress-reporter-update reporter value suffix)))) (defmacro with-tramp-progress-reporter (vec level message &rest body) "Executes BODY, spinning a progress reporter with MESSAGE. @@ -1829,7 +2006,7 @@ letter into the file name. This function removes it." (save-match-data (funcall (if (tramp-compat-file-name-quoted-p name) - 'tramp-compat-file-name-quote 'identity) + #'tramp-compat-file-name-quote #'identity) (let ((name (tramp-compat-file-name-unquote name))) (if (string-match "\\`[a-zA-Z]:/" name) (replace-match "/" nil t name) @@ -1837,7 +2014,6 @@ letter into the file name. This function removes it." ;;; Config Manipulation Functions: -;;;###tramp-autoload (defun tramp-set-completion-function (method function-list) "Sets the list of completion functions for METHOD. FUNCTION-LIST is a list of entries of the form (FUNCTION FILE). @@ -1851,7 +2027,6 @@ Example: \"ssh\" \\='((tramp-parse-sconfig \"/etc/ssh_config\") (tramp-parse-sconfig \"~/.ssh/config\")))" - (let ((r function-list) (v function-list)) (setq tramp-completion-function-alist @@ -1866,13 +2041,13 @@ Example: (unless (and (functionp (nth 0 (car v))) (cond ;; Windows registry. - ((string-match "^HKEY_CURRENT_USER" (nth 1 (car v))) + ((string-match-p "^HKEY_CURRENT_USER" (nth 1 (car v))) (and (memq system-type '(cygwin windows-nt)) (zerop (tramp-call-process v "reg" nil nil nil "query" (nth 1 (car v)))))) ;; Zeroconf service type. - ((string-match + ((string-match-p "^_[[:alpha:]]+\\._[[:alpha:]]+$" (nth 1 (car v)))) ;; Configuration file. (t (file-exists-p (nth 1 (car v)))))) @@ -1889,82 +2064,13 @@ For definition of that list see `tramp-set-completion-function'." (append `(;; Default settings are taken into account. (tramp-parse-default-user-host ,method) + ;; Hits from auth-sources. + (tramp-parse-auth-sources ,method) ;; Hosts visited once shall be remembered. (tramp-parse-connection-properties ,method)) ;; The method related defaults. (cdr (assoc method tramp-completion-function-alist)))) -;;; Fontification of `read-file-name': - -(defvar tramp-rfn-eshadow-overlay) -(make-variable-buffer-local 'tramp-rfn-eshadow-overlay) - -(defun tramp-rfn-eshadow-setup-minibuffer () - "Set up a minibuffer for `file-name-shadow-mode'. -Adds another overlay hiding filename parts according to Tramp's -special handling of `substitute-in-file-name'." - (when minibuffer-completing-file-name - (setq tramp-rfn-eshadow-overlay - (make-overlay (minibuffer-prompt-end) (minibuffer-prompt-end))) - ;; Copy rfn-eshadow-overlay properties. - (let ((props (overlay-properties rfn-eshadow-overlay))) - (while props - ;; The `field' property prevents correct minibuffer - ;; completion; we exclude it. - (if (not (eq (car props) 'field)) - (overlay-put tramp-rfn-eshadow-overlay (pop props) (pop props)) - (pop props) (pop props)))))) - -(add-hook 'rfn-eshadow-setup-minibuffer-hook - 'tramp-rfn-eshadow-setup-minibuffer) -(add-hook 'tramp-unload-hook - (lambda () - (remove-hook 'rfn-eshadow-setup-minibuffer-hook - 'tramp-rfn-eshadow-setup-minibuffer))) - -(defun tramp-rfn-eshadow-update-overlay-regexp () - (format "[^%s/~]*\\(/\\|~\\)" tramp-postfix-host-format)) - -;; Package rfn-eshadow is preloaded in Emacs, but for some reason, -;; it only did (defvar rfn-eshadow-overlay) without giving it a global -;; value, so it was only declared as dynamically-scoped within the -;; rfn-eshadow.el file. This is now fixed in Emacs>26.1 but we still need -;; this defvar here for older releases. -(defvar rfn-eshadow-overlay) - -(defun tramp-rfn-eshadow-update-overlay () - "Update `rfn-eshadow-overlay' to cover shadowed part of minibuffer input. -This is intended to be used as a minibuffer `post-command-hook' for -`file-name-shadow-mode'; the minibuffer should have already -been set up by `rfn-eshadow-setup-minibuffer'." - ;; In remote files name, there is a shadowing just for the local part. - (ignore-errors - (let ((end (or (overlay-end rfn-eshadow-overlay) - (minibuffer-prompt-end))) - ;; We do not want to send any remote command. - (non-essential t)) - (when (tramp-tramp-file-p (buffer-substring end (point-max))) - (save-excursion - (save-restriction - (narrow-to-region - (1+ (or (string-match - (tramp-rfn-eshadow-update-overlay-regexp) - (buffer-string) end) - end)) - (point-max)) - (let ((rfn-eshadow-overlay tramp-rfn-eshadow-overlay) - (rfn-eshadow-update-overlay-hook nil) - file-name-handler-alist) - (move-overlay rfn-eshadow-overlay (point-max) (point-max)) - (rfn-eshadow-update-overlay)))))))) - -(add-hook 'rfn-eshadow-update-overlay-hook - 'tramp-rfn-eshadow-update-overlay) -(add-hook 'tramp-unload-hook - (lambda () - (remove-hook 'rfn-eshadow-update-overlay-hook - 'tramp-rfn-eshadow-update-overlay))) - ;; Inodes don't exist for some file systems. Therefore we must ;; generate virtual ones. Used in `find-buffer-visiting'. The method ;; applied might be not so efficient (Ange-FTP uses hashes). But @@ -1986,26 +2092,12 @@ been set up by `rfn-eshadow-setup-minibuffer'." If the file modes of FILENAME cannot be determined, return the value of `default-file-modes', without execute permissions." (or (file-modes filename) - (logand (default-file-modes) (string-to-number "0666" 8)))) + (logand (default-file-modes) #o0666))) (defun tramp-replace-environment-variables (filename) "Replace environment variables in FILENAME. Return the string with the replaced variables." - (or (ignore-errors - ;; Optional arg has been introduced with Emacs 24.4. - (tramp-compat-funcall 'substitute-env-vars filename 'only-defined)) - ;; We need an own implementation. - (save-match-data - (let ((idx (string-match "$\\(\\w+\\)" filename))) - ;; `$' is coded as `$$'. - (when (and idx - (or (zerop idx) (not (eq ?$ (aref filename (1- idx))))) - (getenv (match-string 1 filename))) - (setq filename - (replace-match - (substitute-in-file-name (match-string 0 filename)) - t nil filename))) - filename)))) + (substitute-env-vars filename 'only-defined)) (defun tramp-find-file-name-coding-system-alist (filename tmpname) "Like `find-operation-coding-system' for Tramp filenames. @@ -2015,7 +2107,7 @@ expression, which matches more than the file name suffix, the coding system might not be determined. This function repairs it." (let (result) (dolist (elt file-coding-system-alist (nreverse result)) - (when (and (consp elt) (string-match (car elt) filename)) + (when (and (consp elt) (string-match-p (car elt) filename)) ;; We found a matching entry in `file-coding-system-alist'. ;; So we add a similar entry, but with the temporary file name ;; as regexp. @@ -2029,12 +2121,14 @@ pass to the OPERATION." `(tramp-file-name-handler tramp-vc-file-name-handler tramp-completion-file-name-handler + tramp-archive-file-name-handler cygwin-mount-name-hook-function cygwin-mount-map-drive-hook-function . ,(and (eq inhibit-file-name-operation operation) inhibit-file-name-handlers))) - (inhibit-file-name-operation operation)) + (inhibit-file-name-operation operation) + signal-hook-function) (apply operation args))) ;; We handle here all file primitives. Most of them have the file @@ -2046,7 +2140,11 @@ pass to the OPERATION." ;; function as well but regexp only. (defun tramp-file-name-for-operation (operation &rest args) "Return file name related to OPERATION file primitive. -ARGS are the arguments OPERATION has been called with." +ARGS are the arguments OPERATION has been called with. + +It does not always return a Tramp file name, for example if the +first argument of `expand-file-name' is absolute and not remote. +Must be handled by the callers." (cond ;; FILE resp DIRECTORY. ((member operation @@ -2062,7 +2160,7 @@ ARGS are the arguments OPERATION has been called with." file-ownership-preserved-p file-readable-p file-regular-p file-remote-p file-selinux-context file-symlink-p file-truename file-writable-p - find-backup-file-name find-file-noselect get-file-buffer + find-backup-file-name get-file-buffer insert-directory insert-file-contents load make-directory make-directory-internal set-file-acl set-file-modes set-file-selinux-context set-file-times @@ -2071,26 +2169,32 @@ ARGS are the arguments OPERATION has been called with." ;; Emacs 26+ only. file-name-case-insensitive-p ;; Emacs 27+ only. - file-system-info)) + file-system-info + ;; Tramp internal magic file name function. + tramp-set-file-uid-gid)) (if (file-name-absolute-p (nth 0 args)) (nth 0 args) default-directory)) + ;; STRING FILE. + ;; Starting with Emacs 26.1, just the 2nd argument of + ;; `make-symbolic-link' matters. + ((eq operation 'make-symbolic-link) (nth 1 args)) ;; FILE DIRECTORY resp FILE1 FILE2. ((member operation - '(add-name-to-file copy-directory copy-file expand-file-name + '(add-name-to-file copy-directory copy-file file-equal-p file-in-directory-p file-name-all-completions file-name-completion - ;; Starting with Emacs 26.1, just the 2nd argument of - ;; `make-symbolic-link' matters. For backward - ;; compatibility, we still accept the first argument as - ;; file name to be checked. Handled properly in - ;; `tramp-handle-*-make-symbolic-link'. - file-newer-than-file-p make-symbolic-link rename-file)) - (save-match-data - (cond - ((tramp-tramp-file-p (nth 0 args)) (nth 0 args)) - ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) - (t default-directory)))) + file-newer-than-file-p rename-file)) + (cond + ((tramp-tramp-file-p (nth 0 args)) (nth 0 args)) + ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) + (t default-directory))) + ;; FILE DIRECTORY resp FILE1 FILE2. + ((eq operation 'expand-file-name) + (cond + ((file-name-absolute-p (nth 0 args)) (nth 0 args)) + ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) + (t default-directory))) ;; START END FILE. ((eq operation 'write-region) (if (file-name-absolute-p (nth 2 args)) @@ -2106,7 +2210,9 @@ ARGS are the arguments OPERATION has been called with." ((member operation '(process-file shell-command start-file-process ;; Emacs 26+ only. - make-nearby-temp-file temporary-file-directory)) + make-nearby-temp-file temporary-file-directory + ;; Emacs 27+ only. + exec-path make-process)) default-directory) ;; PROC. ((member operation @@ -2132,15 +2238,6 @@ ARGS are the arguments OPERATION has been called with." res (cdr elt)))) res))) -(defvar tramp-debug-on-error nil - "Like `debug-on-error' but used Tramp internal.") - -(defmacro tramp-condition-case-unless-debug - (var bodyform &rest handlers) - "Like `condition-case-unless-debug' but `tramp-debug-on-error'." - `(let ((debug-on-error tramp-debug-on-error)) - (condition-case-unless-debug ,var ,bodyform ,@handlers))) - ;; In Emacs, there is some concurrency due to timers. If a timer ;; interrupts Tramp and wishes to use the same connection buffer as ;; the "main" Emacs, then garbage might occur in the connection @@ -2172,100 +2269,96 @@ preventing reentrant calls of Tramp.") (defun tramp-file-name-handler (operation &rest args) "Invoke Tramp file name handler. Falls back to normal file name handler if no Tramp file name handler exists." - (let ((filename (apply 'tramp-file-name-for-operation operation args))) - (if (and tramp-mode (tramp-tramp-file-p filename)) + (let ((filename (apply #'tramp-file-name-for-operation operation args)) + ;; `file-remote-p' is called for everything, even for symbolic + ;; links which look remote. We don't want to get an error. + (non-essential (or non-essential (eq operation 'file-remote-p)))) + (if (tramp-tramp-file-p filename) (save-match-data (setq filename (tramp-replace-environment-variables filename)) (with-parsed-tramp-file-name filename nil - (let ((completion (tramp-completion-mode-p)) + (let ((current-connection tramp-current-connection) (foreign (tramp-find-foreign-file-name-handler filename operation)) + (signal-hook-function #'tramp-signal-hook-function) result) + ;; Set `tramp-current-connection'. + (unless + (tramp-file-name-equal-p v (car tramp-current-connection)) + (setq tramp-current-connection (list v))) + ;; Call the backend function. - (if foreign - (tramp-condition-case-unless-debug err - (let ((sf (symbol-function foreign))) - ;; Some packages set the default directory to a - ;; remote path, before respective Tramp packages - ;; are already loaded. This results in - ;; recursive loading. Therefore, we load the - ;; Tramp packages locally. - (when (autoloadp sf) - (let ((default-directory - (tramp-compat-temporary-file-directory))) - (load (cadr sf) 'noerror 'nomessage))) - ;; If `non-essential' is non-nil, Tramp shall - ;; not open a new connection. - ;; If Tramp detects that it shouldn't continue - ;; to work, it throws the `suppress' event. - ;; This could happen for example, when Tramp - ;; tries to open the same connection twice in a - ;; short time frame. - ;; In both cases, we try the default handler then. - (setq result - (catch 'non-essential - (catch 'suppress - (when (and tramp-locked (not tramp-locker)) - (setq tramp-locked nil) - (tramp-error - (car-safe tramp-current-connection) - 'file-error - "Forbidden reentrant call of Tramp")) - (let ((tl tramp-locked)) - (setq tramp-locked t) - (unwind-protect - (let ((tramp-locker t)) - (apply foreign operation args)) - (setq tramp-locked tl)))))) - (cond - ((eq result 'non-essential) - (tramp-message - v 5 "Non-essential received in operation %s" - (cons operation args)) - (tramp-run-real-handler operation args)) - ((eq result 'suppress) - (let (tramp-message-show-message) + (unwind-protect + (if foreign + (let ((sf (symbol-function foreign))) + ;; Some packages set the default directory to + ;; a remote path, before respective Tramp + ;; packages are already loaded. This results + ;; in recursive loading. Therefore, we load + ;; the Tramp packages locally. + (when (autoloadp sf) + ;; FIXME: Not clear why we need these bindings here. + ;; The explanation above is not convincing and + ;; the bug#9114 for which it was added doesn't + ;; clarify the core of the problem. + (let ((default-directory + (tramp-compat-temporary-file-directory)) + file-name-handler-alist) + (autoload-do-load sf foreign))) + ;; (tramp-message + ;; v 4 "Running `%s'..." (cons operation args)) + ;; If `non-essential' is non-nil, Tramp shall + ;; not open a new connection. + ;; If Tramp detects that it shouldn't continue + ;; to work, it throws the `suppress' event. + ;; This could happen for example, when Tramp + ;; tries to open the same connection twice in + ;; a short time frame. + ;; In both cases, we try the default handler then. + (setq result + (catch 'non-essential + (catch 'suppress + (when (and tramp-locked (not tramp-locker)) + (setq tramp-locked nil) + (tramp-error + v 'file-error + "Forbidden reentrant call of Tramp")) + (let ((tl tramp-locked)) + (setq tramp-locked t) + (unwind-protect + (let ((tramp-locker t)) + (apply foreign operation args)) + (setq tramp-locked tl)))))) + ;; (tramp-message + ;; v 4 "Running `%s'...`%s'" (cons operation args) result) + (cond + ((eq result 'non-essential) (tramp-message - v 1 "Suppress received in operation %s" + v 5 "Non-essential received in operation %s" (cons operation args)) - (tramp-cleanup-connection v t) - (tramp-run-real-handler operation args))) - (t result))) - - ;; Trace that somebody has interrupted the operation. - ((debug quit) - (let (tramp-message-show-message) - (tramp-message - v 1 "Interrupt received in operation %s" - (cons operation args))) - ;; Propagate the quit signal. - (signal (car err) (cdr err))) - - ;; When we are in completion mode, some failed - ;; operations shall return at least a default - ;; value in order to give the user a chance to - ;; correct the file name in the minibuffer. - ;; In order to get a full backtrace, one could apply - ;; (setq tramp-debug-on-error t) - (error - (cond - ((and completion (zerop (length localname)) - (memq operation '(file-exists-p file-directory-p))) - t) - ((and completion (zerop (length localname)) - (memq operation - '(expand-file-name file-name-as-directory))) - filename) - ;; Propagate the error. - (t (signal (car err) (cdr err)))))) - - ;; Nothing to do for us. However, since we are in - ;; `tramp-mode', we must suppress the volume letter on - ;; MS Windows. - (setq result (tramp-run-real-handler operation args)) - (if (stringp result) - (tramp-drop-volume-letter result) - result))))) + (tramp-run-real-handler operation args)) + ((eq result 'suppress) + (let (tramp-message-show-message) + (tramp-message + v 1 "Suppress received in operation %s" + (cons operation args)) + (tramp-cleanup-connection v t) + (tramp-run-real-handler operation args))) + (t result))) + + ;; Nothing to do for us. However, since we are in + ;; `tramp-mode', we must suppress the volume + ;; letter on MS Windows. + (setq result (tramp-run-real-handler operation args)) + (if (stringp result) + (tramp-drop-volume-letter result) + result)) + + ;; Reset `tramp-current-connection'. + (unless + (tramp-file-name-equal-p + (car current-connection) (car tramp-current-connection)) + (setq tramp-current-connection current-connection)))))) ;; When `tramp-mode' is not enabled, or the file name is quoted, ;; we don't do anything. @@ -2282,10 +2375,10 @@ Falls back to normal file name handler if no Tramp file name handler exists." ;;;###autoload (progn (defun tramp-autoload-file-name-handler (operation &rest args) "Load Tramp file name handler, and perform OPERATION." + (tramp-unload-file-name-handlers) (if tramp-mode (let ((default-directory temporary-file-directory)) - (load "tramp" 'noerror 'nomessage)) - (tramp-unload-file-name-handlers)) + (load "tramp" 'noerror 'nomessage))) (apply operation args))) ;; `tramp-autoload-file-name-handler' must be registered before @@ -2312,44 +2405,47 @@ remote file names." "^%s$" (regexp-opt (mapcar - 'file-name-sans-extension + #'file-name-sans-extension (directory-files dir nil "^tramp.+\\.elc?$")) 'paren)))) (mapatoms (lambda (atom) (when (and (functionp atom) (autoloadp (symbol-function atom)) - (string-match files-regexp (cadr (symbol-function atom)))) + (string-match-p files-regexp (cadr (symbol-function atom)))) (ignore-errors (setf (cadr (symbol-function atom)) (expand-file-name (cadr (symbol-function atom)) dir)))))))) -(eval-after-load 'tramp (tramp-use-absolute-autoload-file-names)) +(tramp--with-startup (tramp-use-absolute-autoload-file-names)) (defun tramp-register-file-name-handlers () "Add Tramp file name handlers to `file-name-handler-alist'." ;; Remove autoloaded handlers from file name handler alist. Useful, ;; if `tramp-syntax' has been changed. - (dolist (fnh '(tramp-file-name-handler - tramp-completion-file-name-handler - tramp-autoload-file-name-handler)) - (let ((a1 (rassq fnh file-name-handler-alist))) - (setq file-name-handler-alist (delq a1 file-name-handler-alist)))) + (tramp-unload-file-name-handlers) ;; Add the handlers. We do not add anything to the `operations' - ;; property of `tramp-file-name-handler', this shall be done by the + ;; property of `tramp-file-name-handler' and + ;; `tramp-archive-file-name-handler', this shall be done by the ;; respective foreign handlers. (add-to-list 'file-name-handler-alist - (cons tramp-file-name-regexp 'tramp-file-name-handler)) + (cons tramp-file-name-regexp #'tramp-file-name-handler)) (put 'tramp-file-name-handler 'safe-magic t) (add-to-list 'file-name-handler-alist (cons tramp-completion-file-name-regexp - 'tramp-completion-file-name-handler)) + #'tramp-completion-file-name-handler)) (put 'tramp-completion-file-name-handler 'safe-magic t) ;; Mark `operations' the handler is responsible for. (put 'tramp-completion-file-name-handler 'operations - (mapcar 'car tramp-completion-file-name-handler-alist)) + (mapcar #'car tramp-completion-file-name-handler-alist)) + + (when (bound-and-true-p tramp-archive-enabled) + (add-to-list 'file-name-handler-alist + (cons tramp-archive-file-name-regexp + #'tramp-archive-file-name-handler)) + (put 'tramp-archive-file-name-handler 'safe-magic t)) ;; If jka-compr or epa-file are already loaded, move them to the ;; front of `file-name-handler-alist'. @@ -2359,10 +2455,9 @@ remote file names." (setq file-name-handler-alist (cons entry (delete entry file-name-handler-alist))))))) -(eval-after-load 'tramp (tramp-register-file-name-handlers)) +(tramp--with-startup (tramp-register-file-name-handlers)) -;;;###tramp-autoload -(progn (defun tramp-register-foreign-file-name-handler +(defun tramp-register-foreign-file-name-handler (func handler &optional append) "Register (FUNC . HANDLER) in `tramp-foreign-file-name-handler-alist'. FUNC is the function, which determines whether HANDLER is to be called. @@ -2376,8 +2471,8 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." (append (get 'tramp-file-name-handler 'operations) (mapcar - 'car - (symbol-value (intern (concat (symbol-name handler) "-alist"))))))))) + #'car + (symbol-value (intern (concat (symbol-name handler) "-alist")))))))) (defun tramp-exists-file-name-handler (operation &rest args) "Check, whether OPERATION runs a file name handler." @@ -2402,13 +2497,12 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." ;;;###autoload (progn (defun tramp-unload-file-name-handlers () "Unload Tramp file name handlers from `file-name-handler-alist'." - (dolist (fnh '(tramp-file-name-handler - tramp-completion-file-name-handler - tramp-autoload-file-name-handler)) - (let ((a1 (rassq fnh file-name-handler-alist))) - (setq file-name-handler-alist (delq a1 file-name-handler-alist)))))) + (dolist (fnh file-name-handler-alist) + (when (and (symbolp (cdr fnh)) + (string-prefix-p "tramp-" (symbol-name (cdr fnh)))) + (setq file-name-handler-alist (delq fnh file-name-handler-alist)))))) -(add-hook 'tramp-unload-hook 'tramp-unload-file-name-handlers) +(add-hook 'tramp-unload-hook #'tramp-unload-file-name-handlers) ;;; File name handler functions for completion mode: @@ -2442,7 +2536,6 @@ not in completion mode." ;; completions. (defun tramp-completion-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for partial Tramp files." - (let ((fullname (tramp-drop-volume-letter (expand-file-name filename directory))) hop result result1) @@ -2465,7 +2558,6 @@ not in completion mode." (host (tramp-file-name-host elt)) (localname (tramp-file-name-localname elt)) (m (tramp-find-method method user host)) - (tramp-current-user user) ; see `tramp-parse-passwd' all-user-hosts) (unless localname ;; Nothing to complete. @@ -2515,7 +2607,7 @@ not in completion mode." "Like `file-name-completion' for Tramp files." (try-completion filename - (mapcar 'list (file-name-all-completions filename directory)) + (mapcar #'list (file-name-all-completions filename directory)) (when (and predicate (tramp-connectable-p (expand-file-name filename directory))) (lambda (x) (funcall predicate (expand-file-name (car x) directory)))))) @@ -2540,7 +2632,6 @@ not in completion mode." (defun tramp-completion-dissect-file-name (name) "Returns a list of `tramp-file-name' structures. They are collected by `tramp-completion-dissect-file-name1'." - (let* ((x-nil "\\|\\(\\)") (tramp-completion-ipv6-regexp (format @@ -2615,7 +2706,6 @@ They are collected by `tramp-completion-dissect-file-name1'." "Returns a `tramp-file-name' structure matching STRUCTURE. The structure consists of remote method, remote user, remote host and localname (filename on remote host)." - (save-match-data (when (string-match (nth 0 structure) name) (make-tramp-file-name @@ -2633,9 +2723,9 @@ remote host and localname (filename on remote host)." (mapcar (lambda (method) (and method - (string-match (concat "^" (regexp-quote partial-method)) method) + (string-match-p (concat "^" (regexp-quote partial-method)) method) (tramp-completion-make-tramp-file-name method nil nil nil))) - (mapcar 'car tramp-methods))) + (mapcar #'car tramp-methods))) ;; Compares partial user and host names with possible completions. (defun tramp-get-completion-user-host @@ -2646,7 +2736,7 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." ((and partial-user partial-host) (if (and host - (string-match (concat "^" (regexp-quote partial-host)) host) + (string-match-p (concat "^" (regexp-quote partial-host)) host) (string-equal partial-user (or user partial-user))) (setq user partial-user) (setq user nil @@ -2655,13 +2745,15 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." (partial-user (setq host nil) (unless - (and user (string-match (concat "^" (regexp-quote partial-user)) user)) + (and user + (string-match-p (concat "^" (regexp-quote partial-user)) user)) (setq user nil))) (partial-host (setq user nil) (unless - (and host (string-match (concat "^" (regexp-quote partial-host)) host)) + (and host + (string-match-p (concat "^" (regexp-quote partial-host)) host)) (setq host nil))) (t (setq user nil @@ -2676,15 +2768,33 @@ This function is added always in `tramp-get-completion-function' for all methods. Resulting data are derived from default settings." `((,(tramp-find-user method nil nil) ,(tramp-find-host method nil nil)))) +(defcustom tramp-completion-use-auth-sources auth-source-do-cache + "Whether to use `auth-source-search' for completion of user and host names. +This could be disturbing, if it requires a password / passphrase, +as for \"~/.authinfo.gpg\"." + :group 'tramp + :version "27.1" + :type 'boolean) + +(defun tramp-parse-auth-sources (method) + "Return a list of (user host) tuples allowed to access for METHOD. +This function is added always in `tramp-get-completion-function' +for all methods. Resulting data are derived from default settings." + (and tramp-completion-use-auth-sources + (mapcar + (lambda (x) `(,(plist-get x :user) ,(plist-get x :host))) + (auth-source-search + :port method :require '(:port) :max most-positive-fixnum)))) + ;; Generic function. -(defun tramp-parse-group (regexp match-level skip-regexp) +(defun tramp-parse-group (regexp match-level skip-chars) "Return a (user host) tuple allowed to access. User is always nil." (let (result) (when (re-search-forward regexp (point-at-eol) t) (setq result (list nil (match-string match-level)))) (or - (> (skip-chars-forward skip-regexp) 0) + (> (skip-chars-forward skip-chars) 0) (forward-line 1)) result)) @@ -2701,11 +2811,10 @@ User is always nil." (goto-char (point-min)) (cl-loop while (not (eobp)) collect (funcall function)))))) -;;;###tramp-autoload (defun tramp-parse-rhosts (filename) "Return a list of (user host) tuples allowed to access. Either user or host may be nil." - (tramp-parse-file filename 'tramp-parse-rhosts-group)) + (tramp-parse-file filename #'tramp-parse-rhosts-group)) (defun tramp-parse-rhosts-group () "Return a (user host) tuple allowed to access. @@ -2720,22 +2829,20 @@ Either user or host may be nil." (forward-line 1) result)) -;;;###tramp-autoload (defun tramp-parse-shosts (filename) "Return a list of (user host) tuples allowed to access. User is always nil." - (tramp-parse-file filename 'tramp-parse-shosts-group)) + (tramp-parse-file filename #'tramp-parse-shosts-group)) (defun tramp-parse-shosts-group () "Return a (user host) tuple allowed to access. User is always nil." (tramp-parse-group (concat "^\\(" tramp-host-regexp "\\)") 1 ",")) -;;;###tramp-autoload (defun tramp-parse-sconfig (filename) "Return a list of (user host) tuples allowed to access. User is always nil." - (tramp-parse-file filename 'tramp-parse-sconfig-group)) + (tramp-parse-file filename #'tramp-parse-sconfig-group)) (defun tramp-parse-sconfig-group () "Return a (user host) tuple allowed to access. @@ -2743,7 +2850,7 @@ User is always nil." (tramp-parse-group (concat "\\(?:^[ \t]*Host\\)" "\\|" "\\(?:^.+\\)" "\\|" "\\(" tramp-host-regexp "\\)") - 1 "[ \t]+")) + 1 " \t")) ;; Generic function. (defun tramp-parse-shostkeys-sknownhosts (dirname regexp) @@ -2758,14 +2865,12 @@ User is always nil." when (and (not (string-match "^\\.\\.?$" f)) (string-match regexp f)) collect (list nil (match-string 1 f))))) -;;;###tramp-autoload (defun tramp-parse-shostkeys (dirname) "Return a list of (user host) tuples allowed to access. User is always nil." (tramp-parse-shostkeys-sknownhosts dirname (concat "^key_[0-9]+_\\(" tramp-host-regexp "\\)\\.pub$"))) -;;;###tramp-autoload (defun tramp-parse-sknownhosts (dirname) "Return a list of (user host) tuples allowed to access. User is always nil." @@ -2773,11 +2878,10 @@ User is always nil." dirname (concat "^\\(" tramp-host-regexp "\\)\\.ssh-\\(dss\\|rsa\\)\\.pub$"))) -;;;###tramp-autoload (defun tramp-parse-hosts (filename) "Return a list of (user host) tuples allowed to access. User is always nil." - (tramp-parse-file filename 'tramp-parse-hosts-group)) + (tramp-parse-file filename #'tramp-parse-hosts-group)) (defun tramp-parse-hosts-group () "Return a (user host) tuple allowed to access. @@ -2785,7 +2889,6 @@ User is always nil." (tramp-parse-group (concat "^\\(" tramp-ipv6-regexp "\\|" tramp-host-regexp "\\)") 1 " \t")) -;;;###tramp-autoload (defun tramp-parse-passwd (filename) "Return a list of (user host) tuples allowed to access. Host is always \"localhost\"." @@ -2796,7 +2899,7 @@ Host is always \"localhost\"." (goto-char (point-min)) (cl-loop while (not (eobp)) collect (tramp-parse-etc-group-group)))) - (tramp-parse-file filename 'tramp-parse-passwd-group)))) + (tramp-parse-file filename #'tramp-parse-passwd-group)))) (defun tramp-parse-passwd-group () "Return a (user host) tuple allowed to access. @@ -2808,7 +2911,6 @@ Host is always \"localhost\"." (forward-line 1) result)) -;;;###tramp-autoload (defun tramp-parse-etc-group (filename) "Return a list of (group host) tuples allowed to access. Host is always \"localhost\"." @@ -2819,7 +2921,7 @@ Host is always \"localhost\"." (goto-char (point-min)) (cl-loop while (not (eobp)) collect (tramp-parse-etc-group-group)))) - (tramp-parse-file filename 'tramp-parse-etc-group-group)))) + (tramp-parse-file filename #'tramp-parse-etc-group-group)))) (defun tramp-parse-etc-group-group () "Return a (group host) tuple allowed to access. @@ -2831,26 +2933,18 @@ Host is always \"localhost\"." (forward-line 1) result)) -;;;###tramp-autoload (defun tramp-parse-netrc (filename) "Return a list of (user host) tuples allowed to access. User may be nil." - (tramp-parse-file filename 'tramp-parse-netrc-group)) - -(defun tramp-parse-netrc-group () - "Return a (user host) tuple allowed to access. -User may be nil." - (let ((result) - (regexp - (concat - "^[ \t]*machine[ \t]+" "\\(" tramp-host-regexp "\\)" - "\\([ \t]+login[ \t]+" "\\(" tramp-user-regexp "\\)" "\\)?"))) - (when (re-search-forward regexp (point-at-eol) t) - (setq result (list (match-string 3) (match-string 1)))) - (forward-line 1) - result)) + ;; The declaration is not sufficient at runtime, because netrc.el is + ;; not autoloaded. + (autoload 'netrc-parse "netrc") + (mapcar + (lambda (item) + (and (assoc "machine" item) + `(,(cdr (assoc "login" item)) ,(cdr (assoc "machine" item))))) + (netrc-parse filename))) -;;;###tramp-autoload (defun tramp-parse-putty (registry-or-dirname) "Return a list of (user host) tuples allowed to access. User is always nil." @@ -2884,6 +2978,13 @@ User is always nil." (defvar tramp-handle-write-region-hook nil "Normal hook to be run at the end of `tramp-*-handle-write-region'.") +(defun tramp-handle-access-file (filename string) + "Like `access-file' for Tramp files." + (unless (file-readable-p filename) + (tramp-error + (tramp-dissect-file-name filename) tramp-file-missing + "%s: No such file or directory %s" string filename))) + (defun tramp-handle-add-name-to-file (filename newname &optional ok-if-already-exists) "Like `add-name-to-file' for Tramp files." @@ -2905,8 +3006,8 @@ User is always nil." localname))))) (tramp-error v 'file-already-exists newname) (delete-file newname))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (copy-file filename newname 'ok-if-already-exists 'keep-time 'preserve-uid-gid 'preserve-permissions))) @@ -2932,10 +3033,10 @@ User is always nil." (while temp (setq item (directory-file-name (pop temp))) - (when (or (null match) (string-match match item)) + (when (or (null match) (string-match-p match item)) (push (if full (concat directory item) item) result))) - (if nosort result (sort result 'string<))))) + (if nosort result (sort result #'string<))))) (defun tramp-handle-directory-files-and-attributes (directory &optional full match nosort id-format) @@ -2950,22 +3051,51 @@ User is always nil." "Like `dired-uncache' for Tramp files." (with-parsed-tramp-file-name (if (file-directory-p dir) dir (file-name-directory dir)) nil - (tramp-flush-directory-property v localname))) + (tramp-flush-directory-properties v localname))) + +(defun tramp-handle-expand-file-name (name &optional dir) + "Like `expand-file-name' for Tramp files." + ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". + (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 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)) + ;; Dissect NAME. + (with-parsed-tramp-file-name name nil + (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) + (setq localname (concat "/" localname))) + ;; 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)))))))) (defun tramp-handle-file-accessible-directory-p (filename) "Like `file-accessible-directory-p' for Tramp files." (and (file-directory-p filename) (file-readable-p filename))) +(defun tramp-handle-file-directory-p (filename) + "Like `file-directory-p' for Tramp files." + (eq (tramp-compat-file-attribute-type + (file-attributes (file-truename filename))) + t)) + (defun tramp-handle-file-equal-p (filename1 filename2) "Like `file-equalp-p' for Tramp files." ;; Native `file-equalp-p' calls `file-truename', which requires a ;; remote connection. This can be avoided, if FILENAME1 and ;; FILENAME2 are not located on the same remote host. - (when (string-equal - (file-remote-p (expand-file-name filename1)) - (file-remote-p (expand-file-name filename2))) - (tramp-run-real-handler 'file-equal-p (list filename1 filename2)))) + (when (tramp-equal-remote + (expand-file-name filename1) (expand-file-name filename2)) + (tramp-run-real-handler #'file-equal-p (list filename1 filename2)))) (defun tramp-handle-file-exists-p (filename) "Like `file-exists-p' for Tramp files." @@ -2976,10 +3106,20 @@ User is always nil." ;; Native `file-in-directory-p' calls `file-truename', which ;; requires a remote connection. This can be avoided, if FILENAME ;; and DIRECTORY are not located on the same remote host. - (when (string-equal - (file-remote-p (expand-file-name filename)) - (file-remote-p (expand-file-name directory))) - (tramp-run-real-handler 'file-in-directory-p (list filename directory)))) + (when (tramp-equal-remote + (expand-file-name filename) (expand-file-name directory)) + (tramp-run-real-handler #'file-in-directory-p (list filename directory)))) + +(defun tramp-handle-file-local-copy (filename) + "Like `file-local-copy' for Tramp files." + (with-parsed-tramp-file-name filename nil + (unless (file-exists-p filename) + (tramp-error + v tramp-file-missing + "Cannot make local copy of non-existing file `%s'" filename)) + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) + tmpfile))) (defun tramp-handle-file-modes (filename) "Like `file-modes' for Tramp files." @@ -2997,17 +3137,11 @@ User is always nil." ;; Run the command on the localname portion only unless we are in ;; completion mode. (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-domain v) - (tramp-file-name-host v) - (tramp-file-name-port v) - (if (and (zerop (length (tramp-file-name-localname v))) - (not (tramp-connectable-p file))) - "" - (tramp-run-real-handler - 'file-name-as-directory (list (or (tramp-file-name-localname v) "")))) - (tramp-file-name-hop v)))) + v (or (and (zerop (length (tramp-file-name-localname v))) + (not (tramp-connectable-p file))) + (tramp-run-real-handler + #'file-name-as-directory + (list (tramp-file-name-localname v))))))) (defun tramp-handle-file-name-case-insensitive-p (filename) "Like `file-name-case-insensitive-p' for Tramp files." @@ -3034,8 +3168,8 @@ User is always nil." ;; Check, whether we find an existing file with ;; lower case letters. This avoids us to create a ;; temporary file. - (while (and (string-match - "[a-z]" (file-remote-p candidate 'localname)) + (while (and (string-match-p + "[a-z]" (tramp-compat-file-local-name candidate)) (not (file-exists-p candidate))) (setq candidate (directory-file-name @@ -3045,8 +3179,8 @@ User is always nil." ;; to Emacs 26+ like `file-name-case-insensitive-p', ;; so there is no compatibility problem calling it. (unless - (string-match - "[a-z]" (file-remote-p candidate 'localname)) + (string-match-p + "[a-z]" (tramp-compat-file-local-name candidate)) (setq tmpfile (let ((default-directory (file-name-directory filename))) @@ -3059,27 +3193,23 @@ User is always nil." (file-exists-p (concat (file-remote-p candidate) - (upcase (file-remote-p candidate 'localname)))) + (upcase (tramp-compat-file-local-name candidate)))) ;; Cleanup. (when tmpfile (delete-file tmpfile))))))))))) (defun tramp-handle-file-name-completion (filename directory &optional predicate) "Like `file-name-completion' for Tramp files." - (unless (tramp-tramp-file-p directory) - (error - "tramp-handle-file-name-completion invoked on non-tramp directory `%s'" - directory)) (let (hits-ignored-extensions) (or (try-completion filename (file-name-all-completions filename directory) (lambda (x) - (when (funcall (or predicate 'identity) (expand-file-name x directory)) + (when (funcall (or predicate #'identity) (expand-file-name x directory)) (not (and completion-ignored-extensions - (string-match + (string-match-p (concat (regexp-opt completion-ignored-extensions 'paren) "$") x) ;; We remember the hit. (push x hits-ignored-extensions)))))) @@ -3090,24 +3220,19 @@ User is always nil." "Like `file-name-directory' but aware of Tramp files." ;; Everything except the last filename thing is the directory. We ;; cannot apply `with-parsed-tramp-file-name', because this expands - ;; the remote file name parts. This is a problem when we are in - ;; file name completion. + ;; the remote file name parts. (let ((v (tramp-dissect-file-name file t))) - ;; Run the command on the localname portion only. + ;; Run the command on the localname portion only. If this returns + ;; nil, mark also the localname part of `v' as nil. (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-domain v) - (tramp-file-name-host v) - (tramp-file-name-port v) - (tramp-run-real-handler - 'file-name-directory (list (or (tramp-file-name-localname v) ""))) - (tramp-file-name-hop v)))) + v (or (tramp-run-real-handler + #'file-name-directory (list (tramp-file-name-localname v))) + 'noloc)))) (defun tramp-handle-file-name-nondirectory (file) "Like `file-name-nondirectory' but aware of Tramp files." (with-parsed-tramp-file-name file nil - (tramp-run-real-handler 'file-name-nondirectory (list localname)))) + (tramp-run-real-handler #'file-name-nondirectory (list localname)))) (defun tramp-handle-file-newer-than-file-p (file1 file2) "Like `file-newer-than-file-p' for Tramp files." @@ -3141,13 +3266,13 @@ User is always nil." (and (or (not connected) c) (cond ((eq identification 'method) method) - ;; Domain and port are appended. + ;; Domain and port are appended to user and host, + ;; respectively. ((eq identification 'user) (tramp-file-name-user-domain v)) ((eq identification 'host) (tramp-file-name-host-port v)) ((eq identification 'localname) localname) ((eq identification 'hop) hop) - (t (tramp-make-tramp-file-name - method user domain host port "" hop))))))))) + (t (tramp-make-tramp-file-name v 'noloc))))))))) (defun tramp-handle-file-selinux-context (_filename) "Like `file-selinux-context' for Tramp files." @@ -3164,7 +3289,7 @@ User is always nil." ;; Preserve trailing "/". (funcall (if (string-equal (file-name-nondirectory filename) "") - 'file-name-as-directory 'identity) + #'file-name-as-directory #'identity) (let ((result (expand-file-name filename)) (numchase 0) ;; Don't make the following value larger than necessary. @@ -3174,30 +3299,44 @@ User is always nil." (numchase-limit 20) symlink-target) (with-parsed-tramp-file-name result v1 - (with-tramp-file-property v1 v1-localname "file-truename" - (while (and (setq symlink-target (file-symlink-p result)) - (< numchase numchase-limit)) - (setq numchase (1+ numchase) - result - (with-parsed-tramp-file-name (expand-file-name result) v2 - (tramp-make-tramp-file-name - v2-method v2-user v2-domain v2-host v2-port - (funcall - (if (tramp-compat-file-name-quoted-p v2-localname) - 'tramp-compat-file-name-quote 'identity) - - (if (stringp symlink-target) - (if (file-remote-p symlink-target) - (let (file-name-handler-alist) - (tramp-compat-file-name-quote symlink-target)) - (expand-file-name - symlink-target (file-name-directory v2-localname))) - v2-localname))))) - (when (>= numchase numchase-limit) - (tramp-error - v1 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit))) - (directory-file-name result)))))) + ;; We cache only the localname. + (tramp-make-tramp-file-name + v1 + (with-tramp-file-property v1 v1-localname "file-truename" + (while (and (setq symlink-target (file-symlink-p result)) + (< numchase numchase-limit)) + (setq numchase (1+ numchase) + result + (with-parsed-tramp-file-name (expand-file-name result) v2 + (tramp-make-tramp-file-name + v2 + (funcall + (if (tramp-compat-file-name-quoted-p v2-localname) + #'tramp-compat-file-name-quote #'identity) + + (if (stringp symlink-target) + (if (file-remote-p symlink-target) + (let (file-name-handler-alist) + (tramp-compat-file-name-quote symlink-target)) + (expand-file-name + symlink-target (file-name-directory v2-localname))) + v2-localname)) + 'nohop))) + (when (>= numchase numchase-limit) + (tramp-error + v1 'file-error + "Maximum number (%d) of symlinks exceeded" numchase-limit))) + (tramp-compat-file-local-name (directory-file-name result)))))))) + +(defun tramp-handle-file-writable-p (filename) + "Like `file-writable-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-writable-p" + (if (file-exists-p filename) + (tramp-check-cached-permissions v ?w) + ;; If file doesn't exist, check if directory is writable. + (and (file-directory-p (file-name-directory filename)) + (file-writable-p (file-name-directory filename))))))) (defun tramp-handle-find-backup-file-name (filename) "Like `find-backup-file-name' for Tramp files." @@ -3211,12 +3350,11 @@ User is always nil." (if (and (stringp (cdr x)) (file-name-absolute-p (cdr x)) (not (tramp-tramp-file-p (cdr x)))) - (tramp-make-tramp-file-name - method user domain host port (cdr x) hop) + (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))))) + (tramp-run-real-handler #'find-backup-file-name (list filename))))) (defun tramp-handle-insert-directory (filename switches &optional wildcard full-directory-p) @@ -3226,16 +3364,20 @@ User is always nil." (when (and (zerop (length (file-name-nondirectory filename))) (not full-directory-p)) (setq switches (concat switches "F"))) + ;; Check, whether directory is accessible. + (unless wildcard + (access-file filename "Reading directory")) (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-progress-reporter v 0 (format "Opening directory %s" filename) - (require 'ls-lisp) (let (ls-lisp-use-insert-directory-program start) + ;; Silence byte compiler. + ls-lisp-use-insert-directory-program (tramp-run-real-handler - 'insert-directory + #'insert-directory (list filename switches wildcard full-directory-p)) ;; `ls-lisp' always returns full listings. We must remove ;; superfluous parts. - (unless (string-match "l" switches) + (unless (string-match-p "l" switches) (save-excursion (goto-char (point-min)) (while (setq start @@ -3245,7 +3387,7 @@ User is always nil." start (or (text-property-any start (point-at-eol) 'dired-filename t) (point-at-eol))) - (if (= (point-at-bol) (point-at-eol)) + (if (= (point-at-bol) (point-at-eol)) ;; Empty line. (delete-region (point) (progn (forward-line) (point))) (forward-line))))))))) @@ -3273,7 +3415,7 @@ User is always nil." ;; run directly. (setq result (tramp-run-real-handler - 'insert-file-contents + #'insert-file-contents (list localname visit beg end replace))) ;; When we shall insert only a part of the file, we @@ -3317,7 +3459,7 @@ User is always nil." ((stringp remote-copy) (file-local-copy (tramp-make-tramp-file-name - method user domain host port remote-copy))) + v remote-copy 'nohop))) ((stringp tramp-temp-buffer-file-name) (copy-file filename tramp-temp-buffer-file-name 'ok) @@ -3327,7 +3469,7 @@ User is always nil." ;; When the file is not readable for the owner, it ;; cannot be inserted, even if it is readable for the ;; group or for everybody. - (set-file-modes local-copy (string-to-number "0600" 8)) + (set-file-modes local-copy #o0600) (when (and (null remote-copy) (tramp-get-method-parameter @@ -3361,9 +3503,7 @@ User is always nil." (or remote-copy (null tramp-temp-buffer-file-name))) (delete-file local-copy)) (when (stringp remote-copy) - (delete-file - (tramp-make-tramp-file-name - method user domain host port remote-copy))))) + (delete-file (tramp-make-tramp-file-name v remote-copy 'nohop))))) ;; Result. (list (expand-file-name filename) @@ -3381,14 +3521,13 @@ User is always nil." ;; The first condition is always true for absolute file names. ;; Included for safety's sake. (unless (or (file-name-directory file) - (string-match "\\.elc?\\'" file)) + (string-match-p "\\.elc?\\'" file)) (tramp-error v 'file-error "File `%s' does not include a `.el' or `.elc' suffix" file))) - (unless noerror - (when (not (file-exists-p file)) - (tramp-error - v tramp-file-missing "Cannot load nonexistent file `%s'" file))) + (unless (or noerror (file-exists-p file)) + (tramp-error + v tramp-file-missing "Cannot load nonexistent file `%s'" file)) (if (not (file-exists-p file)) nil (let ((tramp-message-show-message (not nomessage))) @@ -3411,23 +3550,13 @@ support symbolic links." ;; This is needed prior Emacs 26.1, where TARGET has also be ;; checked for a file name handler. (tramp-run-real-handler - 'make-symbolic-link (list target linkname ok-if-already-exists)))) + #'make-symbolic-link (list target linkname ok-if-already-exists)))) (defun tramp-handle-shell-command (command &optional output-buffer error-buffer) "Like `shell-command' for Tramp files." - (let* ((asynchronous (string-match "[ \t]*&[ \t]*\\'" command)) - ;; We cannot use `shell-file-name' and `shell-command-switch', - ;; they are variables of the local host. - (args (append - (cons - (tramp-get-method-parameter - (tramp-dissect-file-name default-directory) - 'tramp-remote-shell) - (tramp-get-method-parameter - (tramp-dissect-file-name default-directory) - 'tramp-remote-shell-args)) - (list (substring command 0 asynchronous)))) + (let* ((asynchronous (string-match-p "[ \t]*&[ \t]*\\'" command)) + (command (substring command 0 asynchronous)) current-buffer-p (output-buffer (cond @@ -3444,19 +3573,48 @@ support symbolic links." (cond ((bufferp error-buffer) error-buffer) ((stringp error-buffer) (get-buffer-create error-buffer)))) - (buffer - (if (and (not asynchronous) error-buffer) - (with-parsed-tramp-file-name default-directory nil - (list output-buffer (tramp-make-tramp-temp-file v))) - output-buffer)) - (p (get-buffer-process output-buffer))) - - ;; Check whether there is another process running. Tramp does not - ;; support 2 (asynchronous) processes in parallel. + (bname (buffer-name output-buffer)) + (p (get-buffer-process output-buffer)) + buffer) + + ;; The following code is taken from `shell-command', slightly + ;; adapted. Shouldn't it be factored out? (when p - (if (yes-or-no-p "A command is running. Kill it? ") - (ignore-errors (kill-process p)) - (tramp-compat-user-error p "Shell command in progress"))) + (cond + ((eq async-shell-command-buffer 'confirm-kill-process) + ;; If will kill a process, query first. + (if (yes-or-no-p + "A command is running in the default buffer. Kill it? ") + (kill-process p) + (tramp-user-error p "Shell command in progress"))) + ((eq async-shell-command-buffer 'confirm-new-buffer) + ;; If will create a new buffer, query first. + (if (yes-or-no-p + "A command is running in the default buffer. Use a new buffer? ") + (setq output-buffer (generate-new-buffer bname)) + (tramp-user-error p "Shell command in progress"))) + ((eq async-shell-command-buffer 'new-buffer) + ;; It will create a new buffer. + (setq output-buffer (generate-new-buffer bname))) + ((eq async-shell-command-buffer 'confirm-rename-buffer) + ;; If will rename the buffer, query first. + (if (yes-or-no-p + "A command is running in the default buffer. Rename it? ") + (progn + (with-current-buffer output-buffer + (rename-uniquely)) + (setq output-buffer (get-buffer-create bname))) + (tramp-user-error p "Shell command in progress"))) + ((eq async-shell-command-buffer 'rename-buffer) + ;; It will rename the buffer. + (with-current-buffer output-buffer + (rename-uniquely)) + (setq output-buffer (get-buffer-create bname))))) + + (setq buffer (if (and (not asynchronous) error-buffer) + (with-parsed-tramp-file-name default-directory nil + (list output-buffer (tramp-make-tramp-temp-file v))) + output-buffer)) (if current-buffer-p (progn @@ -3467,20 +3625,29 @@ support symbolic links." (erase-buffer))) (if (and (not current-buffer-p) (integerp asynchronous)) - (prog1 - ;; Run the process. - (setq p (apply 'start-file-process "*Async Shell*" buffer args)) - ;; Display output. - (with-current-buffer output-buffer - (display-buffer output-buffer '(nil (allow-no-window . t))) - (setq mode-line-process '(":%s")) - (shell-mode) - (set-process-sentinel p 'shell-command-sentinel) - (set-process-filter p 'comint-output-filter))) + (let ((tramp-remote-process-environment + ;; `async-shell-command-width' has been introduced with + ;; Emacs 27.1. + (if (natnump (bound-and-true-p async-shell-command-width)) + (cons (format "COLUMNS=%d" + (bound-and-true-p async-shell-command-width)) + tramp-remote-process-environment) + tramp-remote-process-environment))) + (prog1 + ;; Run the process. + (setq p (start-file-process-shell-command + (buffer-name output-buffer) buffer command)) + ;; Display output. + (with-current-buffer output-buffer + (display-buffer output-buffer '(nil (allow-no-window . t))) + (setq mode-line-process '(":%s")) + (shell-mode) + (set-process-sentinel p #'shell-command-sentinel) + (set-process-filter p #'comint-output-filter)))) (prog1 ;; Run the process. - (apply 'process-file (car args) nil buffer nil (cdr args)) + (process-file-shell-command command nil buffer nil) ;; Insert error messages if they were separated. (when (listp buffer) (with-current-buffer error-buffer @@ -3498,6 +3665,17 @@ support symbolic links." (when (with-current-buffer output-buffer (> (point-max) (point-min))) (display-message-or-buffer output-buffer))))))) +(defun tramp-handle-start-file-process (name buffer program &rest args) + "Like `start-file-process' for Tramp files." + ;; `make-process' knows the `:file-error' argument since Emacs 27.1. + (tramp-file-name-handler + 'make-process + :name name + :buffer buffer + :command (and program (cons program args)) + :noquery nil + :file-handler t)) + (defun tramp-handle-substitute-in-file-name (filename) "Like `substitute-in-file-name' for Tramp files. \"//\" and \"/~\" substitute only in the local filename part." @@ -3507,17 +3685,34 @@ support symbolic links." ;; First, we must replace environment variables. (setq filename (tramp-replace-environment-variables filename)) (with-parsed-tramp-file-name filename nil - ;; Ignore in LOCALNAME everything before "//" or "/~". - (when (and (stringp localname) (string-match ".+?/\\(/\\|~\\)" localname)) - (setq filename - (concat (file-remote-p filename) - (replace-match "\\1" nil nil localname))) - ;; "/m:h:~" does not work for completion. We use "/m:h:~/". - (when (string-match "~$" filename) - (setq filename (concat filename "/")))) - ;; We do not want to replace environment variables, again. + ;; We do not want to replace environment variables, again. "//" + ;; has a special meaning at the beginning of a file name on + ;; Cygwin and MS-Windows, we must remove it. (let (process-environment) - (tramp-run-real-handler 'substitute-in-file-name (list filename)))))) + ;; Ignore in LOCALNAME everything before "//" or "/~". + (when (stringp localname) + (if (string-match "//\\(/\\|~\\)" localname) + (setq filename + (replace-regexp-in-string + "\\`/+" "/" (substitute-in-file-name localname))) + (setq filename + (concat (file-remote-p filename) + (replace-regexp-in-string + "\\`/+" "/" + ;; We must disable cygwin-mount file name + ;; handlers and alike. + (tramp-run-real-handler + #'substitute-in-file-name (list localname)))))))) + ;; "/m:h:~" does not work for completion. We use "/m:h:~/". + (if (and (stringp localname) (string-equal "~" localname)) + (concat filename "/") + filename)))) + +(defconst tramp-time-dont-know '(0 0 0 1000) + "An invalid time value, used as \"Don’t know\" value.") + +(defconst tramp-time-doesnt-exist '(-1 65535) + "An invalid time value, used as \"Doesn’t exist\" value.") (defun tramp-handle-set-visited-file-modtime (&optional time-list) "Like `set-visited-file-modtime' for Tramp files." @@ -3526,14 +3721,12 @@ support symbolic links." (buffer-name))) (unless time-list (let ((remote-file-name-inhibit-cache t)) - ;; '(-1 65535) means file doesn't exists yet. (setq time-list (or (tramp-compat-file-attribute-modification-time (file-attributes (buffer-file-name))) - '(-1 65535))))) - ;; We use '(0 0) as a don't-know value. - (unless (equal time-list '(0 0)) - (tramp-run-real-handler 'set-visited-file-modtime (list time-list)))) + tramp-time-doesnt-exist)))) + (unless (tramp-compat-time-equal-p time-list tramp-time-dont-know) + (tramp-run-real-handler #'set-visited-file-modtime (list time-list)))) (defun tramp-handle-verify-visited-file-modtime (&optional buf) "Like `verify-visited-file-modtime' for Tramp files. @@ -3551,34 +3744,81 @@ of." (eq (visited-file-modtime) 0) (not (file-remote-p f nil 'connected))) t - (with-parsed-tramp-file-name f nil - (let* ((remote-file-name-inhibit-cache t) - (attr (file-attributes f)) - (modtime (tramp-compat-file-attribute-modification-time attr)) - (mt (visited-file-modtime))) - - (cond - ;; File exists, and has a known modtime. - ((and attr (not (equal modtime '(0 0)))) - (< (abs (tramp-time-diff - modtime - ;; For compatibility, deal with both the old - ;; (HIGH . LOW) and the new (HIGH LOW) return - ;; values of `visited-file-modtime'. - (if (atom (cdr mt)) - (list (car mt) (cdr mt)) - mt))) - 2)) - ;; Modtime has the don't know value. - (attr t) - ;; If file does not exist, say it is not modified if and - ;; only if that agrees with the buffer's record. - (t (equal mt '(-1 65535)))))))))) + (let* ((remote-file-name-inhibit-cache t) + (attr (file-attributes f)) + (modtime (tramp-compat-file-attribute-modification-time attr)) + (mt (visited-file-modtime))) + (cond + ;; File exists, and has a known modtime. + ((and attr + (not (tramp-compat-time-equal-p modtime tramp-time-dont-know))) + (< (abs (tramp-time-diff modtime mt)) 2)) + ;; Modtime has the don't know value. + (attr t) + ;; If file does not exist, say it is not modified if and + ;; only if that agrees with the buffer's record. + (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist)))))))) + +(defun tramp-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)) + + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (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 + ;; 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)) + (condition-case nil + (rename-file tmpfile filename 'ok-if-already-exists) + (error + (delete-file tmpfile) + (tramp-error + v 'file-error "Couldn't write region to `%s'" filename)))) + + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + + ;; Set file modification time. + (when (or (eq visit t) (stringp visit)) + (set-visited-file-modtime + (tramp-compat-file-attribute-modification-time + (file-attributes filename)))) + + ;; 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 "/////" + "Marker in stat commands for file attributes.") + +(defconst tramp-stat-quoted-marker "\\/\\/\\/\\/\\/" + "Quoted marker in stat commands for file attributes.") + +;; This is used in tramp-gvfs.el and tramp-sh.el. +(defconst tramp-gio-events + '("attribute-changed" "changed" "changes-done-hint" + "created" "deleted" "moved" "pre-unmount" "unmounted") + "List of events \"gio monitor\" could send.") + +;; This is the default handler. tramp-gvfs.el and tramp-sh.el have +;; their own one. (defun tramp-handle-file-notify-add-watch (filename _flags _callback) "Like `file-notify-add-watch' for Tramp files." - ;; This is the default handler. tramp-gvfs.el and tramp-sh.el have - ;; their own one. (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil (tramp-error @@ -3589,6 +3829,8 @@ of." ;; The descriptor must be a process object. (unless (processp proc) (tramp-error proc 'file-notify-error "Not a valid descriptor %S" proc)) + ;; There might be pending output. + (while (tramp-accept-process-output proc 0)) (tramp-message proc 6 "Kill %S" proc) (delete-process proc)) @@ -3602,6 +3844,12 @@ of." (concat (file-remote-p default-directory) (process-get proc 'watch-name)))))) +(defun tramp-file-notify-process-sentinel (proc event) + "Call `file-notify-rm-watch'." + (unless (process-live-p proc) + (tramp-message proc 5 "Sentinel called: `%S' `%s'" proc event) + (tramp-compat-funcall 'file-notify-rm-watch proc))) + ;;; Functions for establishing connection: ;; The following functions are actions to be taken when seeing certain @@ -3610,17 +3858,17 @@ of." (defun tramp-action-login (_proc vec) "Send the login name." - (when (not (stringp tramp-current-user)) - (setq tramp-current-user - (with-tramp-connection-property vec "login-as" - (save-window-excursion - (let ((enable-recursive-minibuffers t)) - (pop-to-buffer (tramp-get-connection-buffer vec)) - (read-string (match-string 0))))))) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) - (tramp-message vec 3 "Sending login name `%s'" tramp-current-user) - (tramp-send-string vec (concat tramp-current-user tramp-local-end-of-line))) + (let ((user (or (tramp-file-name-user vec) + (with-tramp-connection-property vec "login-as" + (save-window-excursion + (let ((enable-recursive-minibuffers t)) + (pop-to-buffer (tramp-get-connection-buffer vec)) + (read-string (match-string 0)))))))) + (with-current-buffer (tramp-get-connection-buffer vec) + (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message vec 3 "Sending login name `%s'" user) + (tramp-send-string vec (concat user tramp-local-end-of-line))) + t) (defun tramp-action-password (proc vec) "Query the user for a password." @@ -3636,11 +3884,12 @@ of." (tramp-check-for-regexp proc tramp-password-prompt-regexp) (tramp-message vec 3 "Sending %s" (match-string 1)) ;; We don't call `tramp-send-string' in order to hide the - ;; password from the debug buffer. + ;; password from the debug buffer and the traces. (process-send-string proc (concat (tramp-read-passwd proc) tramp-local-end-of-line)) ;; Hide password prompt. - (narrow-to-region (point-max) (point-max))))) + (narrow-to-region (point-max) (point-max)))) + t) (defun tramp-action-succeed (_proc _vec) "Signal success in finding shell prompt." @@ -3657,13 +3906,14 @@ Send \"yes\" to remote process on confirmation, abort otherwise. See also `tramp-action-yn'." (save-window-excursion (let ((enable-recursive-minibuffers t)) - (save-match-data (pop-to-buffer (tramp-get-connection-buffer vec))) + (pop-to-buffer (tramp-get-connection-buffer vec)) (unless (yes-or-no-p (match-string 0)) (kill-process proc) (throw 'tramp-action 'permission-denied)) (with-current-buffer (tramp-get-connection-buffer vec) (tramp-message vec 6 "\n%s" (buffer-string))) - (tramp-send-string vec (concat "yes" tramp-local-end-of-line))))) + (tramp-send-string vec (concat "yes" tramp-local-end-of-line)))) + t) (defun tramp-action-yn (proc vec) "Ask the user for confirmation using `y-or-n-p'. @@ -3671,13 +3921,14 @@ Send \"y\" to remote process on confirmation, abort otherwise. See also `tramp-action-yesno'." (save-window-excursion (let ((enable-recursive-minibuffers t)) - (save-match-data (pop-to-buffer (tramp-get-connection-buffer vec))) + (pop-to-buffer (tramp-get-connection-buffer vec)) (unless (y-or-n-p (match-string 0)) (kill-process proc) (throw 'tramp-action 'permission-denied)) (with-current-buffer (tramp-get-connection-buffer vec) (tramp-message vec 6 "\n%s" (buffer-string))) - (tramp-send-string vec (concat "y" tramp-local-end-of-line))))) + (tramp-send-string vec (concat "y" tramp-local-end-of-line)))) + t) (defun tramp-action-terminal (_proc vec) "Tell the remote host which terminal type to use. @@ -3685,7 +3936,8 @@ The terminal type can be configured with `tramp-terminal-type'." (tramp-message vec 5 "Setting `%s' as terminal type." tramp-terminal-type) (with-current-buffer (tramp-get-connection-buffer vec) (tramp-message vec 6 "\n%s" (buffer-string))) - (tramp-send-string vec (concat tramp-terminal-type tramp-local-end-of-line))) + (tramp-send-string vec (concat tramp-terminal-type tramp-local-end-of-line)) + t) (defun tramp-action-process-alive (proc _vec) "Check, whether a process has finished." @@ -3695,14 +3947,14 @@ The terminal type can be configured with `tramp-terminal-type'." (defun tramp-action-out-of-band (proc vec) "Check, whether an out-of-band copy has finished." ;; There might be pending output for the exit status. - (tramp-accept-process-output proc 0.1) + (while (tramp-accept-process-output proc 0)) (cond ((and (not (process-live-p proc)) (zerop (process-exit-status proc))) (tramp-message vec 3 "Process has finished.") (throw 'tramp-action 'ok)) ((or (and (memq (process-status proc) '(stop exit)) (not (zerop (process-exit-status proc)))) - (memq (process-status proc) '(signal))) + (eq (process-status proc) 'signal)) ;; `scp' could have copied correctly, but set modes could have failed. ;; This can be ignored. (with-current-buffer (process-buffer proc) @@ -3719,13 +3971,14 @@ The terminal type can be configured with `tramp-terminal-type'." ;;; Functions for processing the actions: (defun tramp-process-one-action (proc vec actions) - "Wait for output from the shell and perform one action." + "Wait for output from the shell and perform one action. +See `tramp-process-actions' for the format of ACTIONS." (let ((case-fold-search t) found todo item pattern action) (while (not found) ;; Reread output once all actions have been performed. ;; Obviously, the output was not complete. - (tramp-accept-process-output proc 1) + (while (tramp-accept-process-output proc 0)) (setq todo actions) (while todo (setq item (pop todo)) @@ -3742,14 +3995,32 @@ The terminal type can be configured with `tramp-terminal-type'." "Perform ACTIONS until success or TIMEOUT. PROC and VEC indicate the remote connection to be used. POS, if set, is the starting point of the region to be deleted in the -connection buffer." +connection buffer. + +ACTIONS is a list of (PATTERN ACTION). The PATTERN should be a +symbol, a variable. The value of this variable gives the regular +expression to search for. Note that the regexp must match at the +end of the buffer, \"\\'\" is implicitly appended to it. + +The ACTION should also be a symbol, but a function. When the +corresponding PATTERN matches, the ACTION function is called. + +An ACTION function has two arguments (PROC VEC). If it returns +nil, nothing has been done, and the next action shall be called. +A non-nil return value indicates that the process output has been +consumed, and new output shall be retrieved, before starting to +process all ACTIONs, again. The same happens after calling the +last ACTION. + +If an action determines, that all processing has been done (e.g., +because the shell prompt has been detected), it shall throw a +result. The symbol `ok' means that all ACTIONs have been +performed successfully. Any other value means an error." ;; Enable `auth-source', unless "emacs -Q" has been called. We must - ;; use `tramp-current-*' variables in case we have several hops. + ;; use the "password-vector" property in case we have several hops. (tramp-set-connection-property - (make-tramp-file-name - :method tramp-current-method :user tramp-current-user - :domain tramp-current-domain :host tramp-current-host - :port tramp-current-port) + (tramp-get-connection-property + proc "password-vector" (process-get proc 'vector)) "first-password-request" tramp-cache-read-persistent-data) (save-restriction (with-tramp-progress-reporter @@ -3768,7 +4039,11 @@ connection buffer." (with-current-buffer (tramp-get-connection-buffer vec) (widen) (tramp-message vec 6 "\n%s" (buffer-string))) - (unless (eq exit 'ok) + (if (eq exit 'ok) + (ignore-errors + (and (functionp tramp-password-save-function) + (funcall tramp-password-save-function))) + ;; Not successful. (tramp-clear-passwd vec) (delete-process proc) (tramp-error-with-buffer @@ -3781,9 +4056,10 @@ connection buffer." (tramp-get-connection-buffer vec))) ((eq exit 'process-died) (substitute-command-keys - (concat - "Tramp failed to connect. If this happens repeatedly, try\n" - " `\\[tramp-cleanup-this-connection]'"))) + (eval-when-compile + (concat + "Tramp failed to connect. If this happens repeatedly, try\n" + " `\\[tramp-cleanup-this-connection]'")))) ((eq exit 'timeout) (format-message "Timeout reached, see buffer `%s' for details" @@ -3791,28 +4067,26 @@ connection buffer." (t "Login failed"))))) (when (numberp pos) (with-current-buffer (tramp-get-connection-buffer vec) - (let (buffer-read-only) (delete-region pos (point)))))))) + (let ((inhibit-read-only t)) (delete-region pos (point)))))))) ;;; Utility functions: -(defun tramp-accept-process-output (proc timeout) +(defun tramp-accept-process-output (proc &optional timeout) "Like `accept-process-output' for Tramp processes. This is needed in order to hide `last-coding-system-used', which is set for process communication also." (with-current-buffer (process-buffer proc) - (let (buffer-read-only last-coding-system-used - ;; We do not want to run timers. - timer-list timer-idle-list) - ;; Under Windows XP, `accept-process-output' doesn't return - ;; sometimes. So we add an additional timeout. JUST-THIS-ONE - ;; is set due to Bug#12145. It is an integer, in order to avoid - ;; running timers as well. + (let ((inhibit-read-only t) + last-coding-system-used + result) + ;; JUST-THIS-ONE is set due to Bug#12145. (tramp-message - proc 10 "%s %s %s\n%s" - proc (process-status proc) - (with-timeout (timeout) - (accept-process-output proc timeout nil 0)) - (buffer-string))))) + proc 10 "%s %s %s %s\n%s" + proc timeout (process-status proc) + (with-local-quit + (setq result (accept-process-output proc timeout nil t))) + (buffer-string)) + result))) (defun tramp-check-for-regexp (proc regexp) "Check, whether REGEXP is contained in process buffer of PROC. @@ -3855,31 +4129,34 @@ Erase echoed commands if exists." Expects the output of PROC to be sent to the current buffer. Returns the string that matched, or nil. Waits indefinitely if TIMEOUT is nil." - (with-current-buffer (process-buffer proc) - (let ((found (tramp-check-for-regexp proc regexp))) - (cond (timeout - (with-timeout (timeout) - (while (not found) - (tramp-accept-process-output proc 1) - (unless (process-live-p proc) - (tramp-error-with-buffer - nil proc 'file-error "Process has died")) - (setq found (tramp-check-for-regexp proc regexp))))) - (t + (let ((found (tramp-check-for-regexp proc regexp))) + (cond (timeout + (with-timeout (timeout) (while (not found) - (tramp-accept-process-output proc 1) + (tramp-accept-process-output proc) (unless (process-live-p proc) (tramp-error-with-buffer nil proc 'file-error "Process has died")) (setq found (tramp-check-for-regexp proc regexp))))) - (tramp-message proc 6 "\n%s" (buffer-string)) - (when (not found) - (if timeout - (tramp-error - proc 'file-error "[[Regexp `%s' not found in %d secs]]" - regexp timeout) - (tramp-error proc 'file-error "[[Regexp `%s' not found]]" regexp))) - found))) + (t + (while (not found) + (tramp-accept-process-output proc) + (unless (process-live-p proc) + (tramp-error-with-buffer + nil proc 'file-error "Process has died")) + (setq found (tramp-check-for-regexp proc regexp))))) + ;; The process could have timed out, for example due to session + ;; timeout of sudo. The process buffer does not exist any longer then. + (ignore-errors + (with-current-buffer (process-buffer proc) + (tramp-message proc 6 "\n%s" (buffer-string)))) + (unless found + (if timeout + (tramp-error + proc 'file-error "[[Regexp `%s' not found in %d secs]]" + regexp timeout) + (tramp-error proc 'file-error "[[Regexp `%s' not found]]" regexp))) + found)) ;; It seems that Tru64 Unix does not like it if long strings are sent ;; to it in one go. (This happens when sending the Perl @@ -3901,26 +4178,40 @@ the remote host use line-endings as defined in the variable (with-current-buffer (tramp-get-connection-buffer vec) ;; Clean up the buffer. We cannot call `erase-buffer' because ;; narrowing might be in effect. - (let (buffer-read-only) (delete-region (point-min) (point-max))) + (let ((inhibit-read-only t)) (delete-region (point-min) (point-max))) ;; Replace "\n" by `tramp-rsh-end-of-line'. (setq string (mapconcat - 'identity (split-string string "\n") tramp-rsh-end-of-line)) - (unless (or (string= string "") + #'identity (split-string string "\n") tramp-rsh-end-of-line)) + (unless (or (string-empty-p string) (string-equal (substring string -1) tramp-rsh-end-of-line)) (setq string (concat string tramp-rsh-end-of-line))) ;; Send the string. - (if (and chunksize (not (zerop chunksize))) - (let ((pos 0) - (end (length string))) - (while (< pos end) - (tramp-message - vec 10 "Sending chunk from %s to %s" - pos (min (+ pos chunksize) end)) - (process-send-string - p (substring string pos (min (+ pos chunksize) end))) - (setq pos (+ pos chunksize)))) - (process-send-string p string))))) + (with-local-quit + (if (and chunksize (not (zerop chunksize))) + (let ((pos 0) + (end (length string))) + (while (< pos end) + (tramp-message + vec 10 "Sending chunk from %s to %s" + pos (min (+ pos chunksize) end)) + (process-send-string + p (substring string pos (min (+ pos chunksize) end))) + (setq pos (+ pos chunksize)))) + (process-send-string p string)))))) + +(defun tramp-process-sentinel (proc event) + "Flush file caches and remove shell prompt." + (unless (process-live-p proc) + (let ((vec (process-get proc 'vector)) + (prompt (tramp-get-connection-property proc "prompt" nil))) + (when vec + (tramp-message vec 5 "Sentinel called: `%S' `%s'" proc event) + (tramp-flush-connection-properties proc) + (tramp-flush-directory-properties vec "")) + (goto-char (point-max)) + (when (and prompt (re-search-backward (regexp-quote prompt) nil t)) + (delete-region (point) (point-max)))))) (defun tramp-get-inode (vec) "Returns the virtual inode number. @@ -3934,6 +4225,7 @@ If it doesn't exist, generate a new one." (with-tramp-connection-property (tramp-get-connection-process vec) "device" (cons -1 (setq tramp-devices (1+ tramp-devices))))) +;; Comparision of vectors is performed by `tramp-file-name-equal-p'. (defun tramp-equal-remote (file1 file2) "Check, whether the remote parts of FILE1 and FILE2 are identical. The check depends on method, user and host name of the files. If @@ -3943,16 +4235,17 @@ account. Example: - (tramp-equal-remote \"/ssh::/etc\" \"/<your host name>:/home\") + (tramp-equal-remote \"/ssh::/etc\" \"/-:<your host name>:/home\") would yield t. On the other hand, the following check results in nil: - (tramp-equal-remote \"/sudo::/etc\" \"/su::/etc\")" - (and (tramp-tramp-file-p file1) - (tramp-tramp-file-p file2) - (string-equal (file-remote-p file1) (file-remote-p file2)))) + (tramp-equal-remote \"/sudo::/etc\" \"/su::/etc\") + +If both files are local, the function returns t." + (or (and (null (file-remote-p file1)) (null (file-remote-p file2))) + (and (tramp-tramp-file-p file1) (tramp-tramp-file-p file2) + (string-equal (file-remote-p file1) (file-remote-p file2))))) -;;;###tramp-autoload (defun tramp-mode-string-to-int (mode-string) "Converts a ten-letter `drwxrwxrwx'-style mode string into mode bits." (let* (case-fold-search @@ -3966,53 +4259,52 @@ would yield t. On the other hand, the following check results in nil: (other-read (aref mode-chars 7)) (other-write (aref mode-chars 8)) (other-execute-or-sticky (aref mode-chars 9))) - (save-match-data - (logior - (cond - ((char-equal owner-read ?r) (string-to-number "00400" 8)) - ((char-equal owner-read ?-) 0) - (t (error "Second char `%c' must be one of `r-'" owner-read))) - (cond - ((char-equal owner-write ?w) (string-to-number "00200" 8)) - ((char-equal owner-write ?-) 0) - (t (error "Third char `%c' must be one of `w-'" owner-write))) - (cond - ((char-equal owner-execute-or-setid ?x) (string-to-number "00100" 8)) - ((char-equal owner-execute-or-setid ?S) (string-to-number "04000" 8)) - ((char-equal owner-execute-or-setid ?s) (string-to-number "04100" 8)) - ((char-equal owner-execute-or-setid ?-) 0) - (t (error "Fourth char `%c' must be one of `xsS-'" - owner-execute-or-setid))) - (cond - ((char-equal group-read ?r) (string-to-number "00040" 8)) - ((char-equal group-read ?-) 0) - (t (error "Fifth char `%c' must be one of `r-'" group-read))) - (cond - ((char-equal group-write ?w) (string-to-number "00020" 8)) - ((char-equal group-write ?-) 0) - (t (error "Sixth char `%c' must be one of `w-'" group-write))) - (cond - ((char-equal group-execute-or-setid ?x) (string-to-number "00010" 8)) - ((char-equal group-execute-or-setid ?S) (string-to-number "02000" 8)) - ((char-equal group-execute-or-setid ?s) (string-to-number "02010" 8)) - ((char-equal group-execute-or-setid ?-) 0) - (t (error "Seventh char `%c' must be one of `xsS-'" - group-execute-or-setid))) - (cond - ((char-equal other-read ?r) (string-to-number "00004" 8)) - ((char-equal other-read ?-) 0) - (t (error "Eighth char `%c' must be one of `r-'" other-read))) - (cond - ((char-equal other-write ?w) (string-to-number "00002" 8)) - ((char-equal other-write ?-) 0) - (t (error "Ninth char `%c' must be one of `w-'" other-write))) - (cond - ((char-equal other-execute-or-sticky ?x) (string-to-number "00001" 8)) - ((char-equal other-execute-or-sticky ?T) (string-to-number "01000" 8)) - ((char-equal other-execute-or-sticky ?t) (string-to-number "01001" 8)) - ((char-equal other-execute-or-sticky ?-) 0) - (t (error "Tenth char `%c' must be one of `xtT-'" - other-execute-or-sticky))))))) + (logior + (cond + ((char-equal owner-read ?r) #o0400) + ((char-equal owner-read ?-) 0) + (t (error "Second char `%c' must be one of `r-'" owner-read))) + (cond + ((char-equal owner-write ?w) #o0200) + ((char-equal owner-write ?-) 0) + (t (error "Third char `%c' must be one of `w-'" owner-write))) + (cond + ((char-equal owner-execute-or-setid ?x) #o0100) + ((char-equal owner-execute-or-setid ?S) #o4000) + ((char-equal owner-execute-or-setid ?s) #o4100) + ((char-equal owner-execute-or-setid ?-) 0) + (t (error "Fourth char `%c' must be one of `xsS-'" + owner-execute-or-setid))) + (cond + ((char-equal group-read ?r) #o0040) + ((char-equal group-read ?-) 0) + (t (error "Fifth char `%c' must be one of `r-'" group-read))) + (cond + ((char-equal group-write ?w) #o0020) + ((char-equal group-write ?-) 0) + (t (error "Sixth char `%c' must be one of `w-'" group-write))) + (cond + ((char-equal group-execute-or-setid ?x) #o0010) + ((char-equal group-execute-or-setid ?S) #o2000) + ((char-equal group-execute-or-setid ?s) #o2010) + ((char-equal group-execute-or-setid ?-) 0) + (t (error "Seventh char `%c' must be one of `xsS-'" + group-execute-or-setid))) + (cond + ((char-equal other-read ?r) #o0004) + ((char-equal other-read ?-) 0) + (t (error "Eighth char `%c' must be one of `r-'" other-read))) + (cond + ((char-equal other-write ?w) #o0002) + ((char-equal other-write ?-) 0) + (t (error "Ninth char `%c' must be one of `w-'" other-write))) + (cond + ((char-equal other-execute-or-sticky ?x) #o0001) + ((char-equal other-execute-or-sticky ?T) #o1000) + ((char-equal other-execute-or-sticky ?t) #o1001) + ((char-equal other-execute-or-sticky ?-) 0) + (t (error "Tenth char `%c' must be one of `xtT-'" + other-execute-or-sticky)))))) (defconst tramp-file-mode-type-map '((0 . "-") ; Normal file (SVID-v2 and XPG2) @@ -4033,17 +4325,16 @@ would yield t. On the other hand, the following check results in nil: "A list of file types returned from the `stat' system call. This is used to map a mode number to a permission string.") -;;;###tramp-autoload (defun tramp-file-mode-from-int (mode) "Turn an integer representing a file mode into an ls(1)-like string." (let ((type (cdr - (assoc (logand (lsh mode -12) 15) tramp-file-mode-type-map))) - (user (logand (lsh mode -6) 7)) - (group (logand (lsh mode -3) 7)) - (other (logand (lsh mode -0) 7)) - (suid (> (logand (lsh mode -9) 4) 0)) - (sgid (> (logand (lsh mode -9) 2) 0)) - (sticky (> (logand (lsh mode -9) 1) 0))) + (assoc (logand (ash mode -12) 15) tramp-file-mode-type-map))) + (user (logand (ash mode -6) 7)) + (group (logand (ash mode -3) 7)) + (other (logand (ash mode -0) 7)) + (suid (> (logand (ash mode -9) 4) 0)) + (sgid (> (logand (ash mode -9) 2) 0)) + (sticky (> (logand (ash mode -9) 1) 0))) (setq user (tramp-file-mode-permissions user suid "s")) (setq group (tramp-file-mode-permissions group sgid "s")) (setq other (tramp-file-mode-permissions other sticky "t")) @@ -4061,20 +4352,51 @@ This is used internally by `tramp-file-mode-from-int'." (and suid (upcase suid-text)) ; suid, !execute (and x "x") "-")))) ; !suid -;;;###tramp-autoload +;; This is a Tramp internal function. A general `set-file-uid-gid' +;; outside Tramp is not needed, I believe. +(defun tramp-set-file-uid-gid (filename &optional uid gid) + "Set the ownership for FILENAME. +If UID and GID are provided, these values are used; otherwise uid +and gid of the corresponding remote or local user is taken, +depending whether FILENAME is remote or local. Both parameters +must be non-negative integers. +The setgid bit of the upper directory is respected. +If FILENAME is remote, a file name handler is called." + (let* ((dir (file-name-directory filename)) + (modes (file-modes dir))) + (when (and modes (not (zerop (logand modes #o2000)))) + (setq gid (tramp-compat-file-attribute-group-id (file-attributes dir))))) + + (let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid))) + (if handler + (funcall handler #'tramp-set-file-uid-gid filename uid gid) + ;; On W32 systems, "chown" does not work. + (unless (memq system-type '(ms-dos windows-nt)) + (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer))) + (gid (or (and (natnump gid) gid) (tramp-get-local-gid 'integer)))) + (tramp-call-process + nil "chown" nil nil nil (format "%d:%d" uid gid) + (tramp-unquote-shell-quote-argument filename))))))) + (defun tramp-get-local-uid (id-format) "The uid of the local user, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." - (if (equal id-format 'integer) (user-uid) (user-login-name))) + ;; We use key nil for local connection properties. + (with-tramp-connection-property nil (format "uid-%s" id-format) + (if (equal id-format 'integer) (user-uid) (user-login-name)))) -;;;###tramp-autoload (defun tramp-get-local-gid (id-format) "The gid of the local user, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." - ;; `group-gid' has been introduced with Emacs 24.4. - (if (and (fboundp 'group-gid) (equal id-format 'integer)) - (tramp-compat-funcall 'group-gid) - (tramp-compat-file-attribute-group-id (file-attributes "~/" id-format)))) + ;; We use key nil for local connection properties. + (with-tramp-connection-property nil (format "gid-%s" id-format) + (cond + ((equal id-format 'integer) (group-gid)) + ;; `group-name' has been introduced with Emacs 27.1. + ((and (fboundp 'group-name) (equal id-format 'string)) + (tramp-compat-funcall 'group-name (group-gid))) + ((tramp-compat-file-attribute-group-id + (file-attributes "~/" id-format)))))) (defun tramp-get-local-locale (&optional vec) "Determine locale, supporting UTF8 if possible. @@ -4089,8 +4411,9 @@ VEC is used for tracing." nil "locale" nil t nil "-a")))) (while candidates (goto-char (point-min)) - (if (string-match (format "^%s\r?$" (regexp-quote (car candidates))) - (buffer-string)) + (if (string-match-p + (format "^%s\r?$" (regexp-quote (car candidates))) + (buffer-string)) (setq locale (car candidates) candidates nil) (setq candidates (cdr candidates)))))) @@ -4098,7 +4421,6 @@ VEC is used for tracing." (when vec (tramp-message vec 7 "locale %s" (or locale "C"))) (or locale "C")))) -;;;###tramp-autoload (defun tramp-check-cached-permissions (vec access) "Check `file-attributes' caches for VEC. Return t if according to the cache access type ACCESS is known to @@ -4119,15 +4441,7 @@ be granted." vec (tramp-file-name-localname vec) (concat "file-attributes-" suffix) nil) (file-attributes - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - (tramp-file-name-localname vec) - (tramp-file-name-hop vec)) - (intern suffix)))) + (tramp-make-tramp-file-name vec) (intern suffix)))) (remote-uid (tramp-get-connection-property vec (concat "uid-" suffix) nil)) @@ -4167,14 +4481,14 @@ be granted." (tramp-compat-file-attribute-group-id file-attr)))))))))))) -;;;###tramp-autoload (defun tramp-local-host-p (vec) - "Return t if this points to the local host, nil otherwise." + "Return t if this points to the local host, nil otherwise. +This handles also chrooted environments, which are not regarded as local." (let ((host (tramp-file-name-host vec)) (port (tramp-file-name-port vec))) (and - (stringp host) - (string-match tramp-local-host-regexp host) + (stringp tramp-local-host-regexp) (stringp host) + (string-match-p tramp-local-host-regexp host) ;; A port is an indication for an ssh tunnel or alike. (null port) ;; The method shall be applied to one of the shell file name @@ -4184,11 +4498,7 @@ be granted." ;; The local temp directory must be writable for the other user. (file-writable-p (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - host port - (tramp-compat-temporary-file-directory))) + vec (tramp-compat-temporary-file-directory) 'nohop)) ;; On some systems, chown runs only for root. (or (zerop (user-uid)) ;; This is defined in tramp-sh.el. Let's assume this is @@ -4198,20 +4508,14 @@ be granted." (defun tramp-get-remote-tmpdir (vec) "Return directory for temporary files on the remote host identified by VEC." (with-tramp-connection-property vec "tmpdir" - (let ((dir (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp") - (tramp-file-name-hop vec)))) + (let ((dir + (tramp-make-tramp-file-name + vec (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp")))) (or (and (file-directory-p dir) (file-writable-p dir) - (file-remote-p dir 'localname)) + (tramp-compat-file-local-name dir)) (tramp-error vec 'file-error "Directory %s not accessible" dir)) dir))) -;;;###tramp-autoload (defun tramp-make-tramp-temp-file (vec) "Create a temporary file on the remote host identified by VEC. Return the local name of the temporary file." @@ -4228,7 +4532,7 @@ Return the local name of the temporary file." (setq result nil) ;; This creates the file by side effect. (set-file-times result) - (set-file-modes result (string-to-number "0700" 8)))) + (set-file-modes result #o0700))) ;; Return the local part. (with-parsed-tramp-file-name result nil localname))) @@ -4238,11 +4542,11 @@ Return the local name of the temporary file." (when (stringp tramp-temp-buffer-file-name) (ignore-errors (delete-file tramp-temp-buffer-file-name)))) -(add-hook 'kill-buffer-hook 'tramp-delete-temp-file-function) +(add-hook 'kill-buffer-hook #'tramp-delete-temp-file-function) (add-hook 'tramp-unload-hook (lambda () (remove-hook 'kill-buffer-hook - 'tramp-delete-temp-file-function))) + #'tramp-delete-temp-file-function))) (defun tramp-handle-make-auto-save-file-name () "Like `make-auto-save-file-name' for Tramp files. @@ -4278,7 +4582,7 @@ this file, if that variable is non-nil." (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))) + (tramp-run-real-handler #'make-auto-save-file-name nil))) (defun tramp-subst-strs-in-string (alist string) "Replace all occurrences of the string FROM with TO in STRING. @@ -4317,22 +4621,19 @@ ALIST is of the form ((FROM . TO) ...)." It always returns a return code. The Lisp error raised when PROGRAM is nil is trapped also, returning 1. Furthermore, traces are written with verbosity of 6." - (let ((default-directory (tramp-compat-temporary-file-directory)) - (v (or vec - (make-tramp-file-name - :method tramp-current-method :user tramp-current-user - :domain tramp-current-domain :host tramp-current-host - :port tramp-current-port))) + (let ((default-directory (tramp-compat-temporary-file-directory)) + (process-environment (default-toplevel-value 'process-environment)) (destination (if (eq destination t) (current-buffer) destination)) + (vec (or vec (car tramp-current-connection))) output error result) (tramp-message - v 6 "`%s %s' %s %s" - program (mapconcat 'identity args " ") infile destination) + vec 6 "`%s %s' %s %s" + program (string-join args " ") infile destination) (condition-case err (with-temp-buffer (setq result (apply - 'call-process program infile (or destination t) display args)) + #'call-process program infile (or destination t) display args)) ;; `result' could also be an error string. (when (stringp result) (setq error result @@ -4344,8 +4645,8 @@ are written with verbosity of 6." (setq error (error-message-string err) result 1))) (if (zerop (length error)) - (tramp-message v 6 "%d\n%s" result output) - (tramp-message v 6 "%d\n%s\n%s" result output error)) + (tramp-message vec 6 "%d\n%s" result output) + (tramp-message vec 6 "%d\n%s\n%s" result output error)) result)) (defun tramp-call-process-region @@ -4354,55 +4655,77 @@ are written with verbosity of 6." It always returns a return code. The Lisp error raised when PROGRAM is nil is trapped also, returning 1. Furthermore, traces are written with verbosity of 6." - (let ((default-directory (tramp-compat-temporary-file-directory)) - (v (or vec - (make-tramp-file-name - :method tramp-current-method :user tramp-current-user - :domain tramp-current-domain :host tramp-current-host - :port tramp-current-port))) + (let ((default-directory (tramp-compat-temporary-file-directory)) + (process-environment (default-toplevel-value 'process-environment)) (buffer (if (eq buffer t) (current-buffer) buffer)) result) (tramp-message - v 6 "`%s %s' %s %s %s %s" - program (mapconcat 'identity args " ") start end delete buffer) + vec 6 "`%s %s' %s %s %s %s" + program (string-join args " ") start end delete buffer) (condition-case err (progn (setq result (apply - 'call-process-region + #'call-process-region start end program delete buffer display args)) ;; `result' could also be an error string. (when (stringp result) (signal 'file-error (list result))) (with-current-buffer (if (bufferp buffer) buffer (current-buffer)) (if (zerop result) - (tramp-message v 6 "%d" result) - (tramp-message v 6 "%d\n%s" result (buffer-string))))) + (tramp-message vec 6 "%d" result) + (tramp-message vec 6 "%d\n%s" result (buffer-string))))) (error (setq result 1) - (tramp-message v 6 "%d\n%s" result (error-message-string err)))) + (tramp-message vec 6 "%d\n%s" result (error-message-string err)))) + result)) + +(defun tramp-process-lines + (vec program &rest args) + "Calls `process-lines' on the local host. +If an error occurs, it returns nil. Traces are written with +verbosity of 6." + (let ((default-directory (tramp-compat-temporary-file-directory)) + (process-environment (default-toplevel-value 'process-environment)) + (vec (or vec (car tramp-current-connection))) + result) + (if args + (tramp-message vec 6 "%s %s" program (string-join args " ")) + (tramp-message vec 6 "%s" program)) + (setq result + (condition-case err + (apply #'process-lines program args) + (error + (tramp-error vec (car err) (cdr err))))) + (tramp-message vec 6 "%s" result) result)) -;;;###tramp-autoload (defun tramp-read-passwd (proc &optional prompt) "Read a password from user (compat function). Consults the auth-source package. Invokes `password-read' if available, `read-passwd' else." (let* ((case-fold-search t) (key (tramp-make-tramp-file-name - tramp-current-method tramp-current-user tramp-current-domain - tramp-current-host tramp-current-port "")) + ;; In tramp-sh.el, we must use "password-vector" due to + ;; multi-hop. + (tramp-get-connection-property + proc "password-vector" (process-get proc 'vector)) + 'noloc 'nohop)) (pw-prompt (or prompt (with-current-buffer (process-buffer proc) (tramp-check-for-regexp proc tramp-password-prompt-regexp) (format "%s for %s " (capitalize (match-string 1)) key)))) + (auth-source-creation-prompts `((secret . ,pw-prompt))) ;; We suspend the timers while reading the password. (stimers (with-timeout-suspend)) auth-info auth-passwd) (unwind-protect (with-parsed-tramp-file-name key nil + (setq tramp-password-save-function nil + user + (or user (tramp-get-connection-property key "login-as" nil))) (prog1 (or ;; See if auth-sources contains something useful. @@ -4411,82 +4734,69 @@ Invokes `password-read' if available, `read-passwd' else." v "first-password-request" nil) ;; Try with Tramp's current method. (setq auth-info - (auth-source-search - :max 1 - (and tramp-current-user :user) - (if tramp-current-domain - (format - "%s%s%s" - tramp-current-user tramp-prefix-domain-format - tramp-current-domain) - tramp-current-user) - :host - (if tramp-current-port - (format - "%s%s%s" - tramp-current-host tramp-prefix-port-format - tramp-current-port) - tramp-current-host) - :port tramp-current-method - :require - (cons - :secret (and tramp-current-user '(:user)))) - auth-passwd (plist-get - (nth 0 auth-info) :secret) - auth-passwd (if (functionp auth-passwd) - (funcall auth-passwd) - auth-passwd)))) + (car + (auth-source-search + :max 1 + (and user :user) + (if domain + (concat + user tramp-prefix-domain-format domain) + user) + :host + (if port + (concat + host tramp-prefix-port-format port) + host) + :port method + :require (cons :secret (and user '(:user))) + :create t)) + tramp-password-save-function + (plist-get auth-info :save-function) + auth-passwd (plist-get auth-info :secret))) + (while (functionp auth-passwd) + (setq auth-passwd (funcall auth-passwd))) + auth-passwd) + ;; Try the password cache. - (let ((password (password-read pw-prompt key))) - (password-cache-add key password) - password) - ;; Else, get the password interactively. + (progn + (setq auth-passwd (password-read pw-prompt key) + tramp-password-save-function + (lambda () (password-cache-add key auth-passwd))) + auth-passwd) + + ;; Else, get the password interactively w/o cache. (read-passwd pw-prompt)) + (tramp-set-connection-property v "first-password-request" nil))) + ;; Reenable the timers. (with-timeout-unsuspend stimers)))) -;;;###tramp-autoload (defun tramp-clear-passwd (vec) "Clear password cache for connection related to VEC." (let ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (domain (tramp-file-name-domain vec)) (user-domain (tramp-file-name-user-domain vec)) - (host (tramp-file-name-host vec)) - (port (tramp-file-name-port vec)) (host-port (tramp-file-name-host-port vec)) (hop (tramp-file-name-hop vec))) (when hop ;; Clear also the passwords of the hops. - (tramp-clear-passwd - (tramp-dissect-file-name - (concat - tramp-prefix-format - (replace-regexp-in-string - (concat tramp-postfix-hop-regexp "$") - tramp-postfix-host-format hop))))) + (tramp-clear-passwd (tramp-dissect-hop-name hop))) (auth-source-forget `(:max 1 ,(and user-domain :user) ,user-domain :host ,host-port :port ,method)) - (password-cache-remove - (tramp-make-tramp-file-name method user domain host port "")))) - -;; Snarfed code from time-date.el. - -(defconst tramp-half-a-year '(241 17024) -"Evaluated by \"(days-to-time 183)\".") + (password-cache-remove (tramp-make-tramp-file-name vec 'noloc 'nohop)))) -;;;###tramp-autoload (defun tramp-time-diff (t1 t2) "Return the difference between the two times, in seconds. T1 and T2 are time values (as returned by `current-time' for example)." - ;; Starting with Emacs 25.1, we could change this to use `time-subtract'. - (float-time (tramp-compat-funcall 'subtract-time t1 t2))) + (float-time (time-subtract t1 t2))) (defun tramp-unquote-shell-quote-argument (s) - "Remove quotation prefix \"/:\" from string S, and quote it then for shell." - (shell-quote-argument (tramp-compat-file-name-unquote s))) + "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)))) ;; Currently (as of Emacs 20.5), the function `shell-quote-argument' ;; does not deal well with newline characters. Newline is replaced by @@ -4509,7 +4819,6 @@ T1 and T2 are time values (as returned by `current-time' for example)." ;; ;; Thanks to Mario DeWeerd for the hint that it is sufficient for this ;; function to work with Bourne-like shells. -;;;###tramp-autoload (defun tramp-shell-quote-argument (s) "Similar to `shell-quote-argument', but groks newlines. Only works for Bourne-like shells." @@ -4541,82 +4850,46 @@ Only works for Bourne-like shells." pid) ;; If it's a Tramp process, send the INT signal remotely. (when (and (processp proc) (setq pid (process-get proc 'remote-pid))) - (if (not (process-live-p proc)) + (if (not (process-live-p proc)) (tramp-error proc 'error "Process %s is not active" proc) (tramp-message proc 5 "Interrupt process %s with pid %s" proc pid) ;; This is for tramp-sh.el. Other backends do not support this (yet). (tramp-compat-funcall 'tramp-send-command - (tramp-get-connection-property proc "vector" nil) - (format "kill -2 %d" pid)) + (process-get proc 'vector) + (format "kill -2 -%d" pid)) ;; Wait, until the process has disappeared. If it doesn't, ;; fall back to the default implementation. - (with-timeout (1 (ignore)) - (while (process-live-p proc) - ;; We cannot run `tramp-accept-process-output', it blocks timers. - (accept-process-output proc 0.1)) - ;; Report success. - proc))))) + (while (tramp-accept-process-output proc 0)) + (not (process-live-p proc)))))) ;; `interrupt-process-functions' exists since Emacs 26.1. (when (boundp 'interrupt-process-functions) - (add-hook 'interrupt-process-functions 'tramp-interrupt-process) + (add-hook 'interrupt-process-functions #'tramp-interrupt-process) (add-hook 'tramp-unload-hook (lambda () - (remove-hook 'interrupt-process-functions 'tramp-interrupt-process)))) - -;;; Integration of eshell.el: - -;; eshell.el keeps the path in `eshell-path-env'. We must change it -;; when `default-directory' points to another host. -(defun tramp-eshell-directory-change () - "Set `eshell-path-env' to $PATH of the host related to `default-directory'." - (setq eshell-path-env - (if (tramp-tramp-file-p default-directory) - (with-parsed-tramp-file-name default-directory nil - (mapconcat - 'identity - (or - ;; When `tramp-own-remote-path' is in `tramp-remote-path', - ;; the remote path is only set in the session cache. - ;; Use `path-separator' as it does eshell. - (tramp-get-connection-property - (tramp-get-connection-process v) "remote-path" nil) - (tramp-get-connection-property v "remote-path" nil)) - path-separator)) - (getenv "PATH")))) - -(eval-after-load "esh-util" - '(progn - (add-hook 'eshell-mode-hook - 'tramp-eshell-directory-change) - (add-hook 'eshell-directory-change-hook - 'tramp-eshell-directory-change) - (add-hook 'tramp-unload-hook - (lambda () - (remove-hook 'eshell-mode-hook - 'tramp-eshell-directory-change) - (remove-hook 'eshell-directory-change-hook - 'tramp-eshell-directory-change))))) + (remove-hook 'interrupt-process-functions #'tramp-interrupt-process)))) ;; Checklist for `tramp-unload-hook' ;; - Unload all `tramp-*' packages ;; - Reset `file-name-handler-alist' ;; - Cleanup hooks where Tramp functions are in -;; - Cleanup advised functions ;; - Cleanup autoloads ;;;###autoload (defun tramp-unload-tramp () "Discard Tramp from loading remote files." (interactive) - ;; ange-ftp settings must be enabled. + ;; ange-ftp settings must be re-enabled. (tramp-compat-funcall 'tramp-ftp-enable-ange-ftp) ;; Maybe it's not loaded yet. (ignore-errors (unload-feature 'tramp 'force))) (provide 'tramp) +(run-hooks 'tramp--startup-hook) +(setq tramp--startup-hook nil) + ;;; TODO: ;; ;; * Avoid screen blanking when hitting `g' in dired. (Eli Tziperman) @@ -4639,6 +4912,12 @@ Only works for Bourne-like shells." ;; and friends, for most of the handlers this is the major ;; difference between the different backends. Other handlers but ;; *-process-file would profit from this as well. +;; +;; * Get rid of `shell-command'. In its primary implementation, it +;; uses `process-file-shell-command' and +;; `start-file-process-shell-command', which is sufficient due to +;; connection-local `shell-file-name'. + ;;; tramp.el ends here diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 81d80d0a5a7..9fe848dbbe2 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -7,7 +7,6 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.3.5.26.3 ;; This file is part of GNU Emacs. @@ -26,39 +25,49 @@ ;;; Code: -;; In the Tramp GIT repository, the version number and the bug report -;; address are auto-frobbed from configure.ac, so you should edit that -;; file and run "autoconf && ./configure" to change them. Emacs -;; version check is defined in macro AC_EMACS_INFO of aclocal.m4; -;; should be changed only there. +;; In the Tramp GIT, the version number is auto-frobbed from tramp.el, +;; and the bug report address is auto-frobbed from configure.ac. +;; Emacs version check is defined in macro AC_EMACS_INFO of +;; aclocal.m4; should be changed only there. ;;;###tramp-autoload -(defconst tramp-version "2.3.5.26.3" +(defconst tramp-version "2.4.3-pre" "This version of Tramp.") ;;;###tramp-autoload (defconst tramp-bug-report-address "tramp-devel@gnu.org" "Email address to send bug reports to.") -(defun tramp-repository-get-version () - "Try to return as a string the repository revision of the Tramp sources." - (let ((dir (locate-dominating-file (locate-library "tramp") ".git"))) - (when dir - (with-temp-buffer - (let ((default-directory (file-name-as-directory dir))) - (and (zerop - (ignore-errors - (call-process "git" nil '(t nil) nil "rev-parse" "HEAD"))) - (not (zerop (buffer-size))) - (replace-regexp-in-string "\n" "" (buffer-string)))))))) +(defconst tramp-repository-branch + (ignore-errors + ;; Suppress message from `emacs-repository-get-branch'. We must + ;; also handle out-of-tree builds. + (let ((inhibit-message t) + (dir (or (locate-dominating-file (locate-library "tramp") ".git") + source-directory))) + ;; `emacs-repository-get-branch' has been introduced with Emacs 27.1. + (with-no-warnings + (and (stringp dir) (file-directory-p dir) + (emacs-repository-get-branch dir))))) + "The repository branch of the Tramp sources.") + +(defconst tramp-repository-version + (ignore-errors + ;; Suppress message from `emacs-repository-get-version'. We must + ;; also handle out-of-tree builds. + (let ((inhibit-message t) + (dir (or (locate-dominating-file (locate-library "tramp") ".git") + source-directory))) + (and (stringp dir) (file-directory-p dir) + (emacs-repository-get-version dir)))) + "The repository revision of the Tramp sources.") ;; Check for Emacs version. -(let ((x (if (>= emacs-major-version 24) - "ok" - (format "Tramp 2.3.5.26.3 is not fit for %s" - (when (string-match "^.*$" (emacs-version)) - (match-string 0 (emacs-version))))))) - (unless (string-match "\\`ok\\'" x) (error "%s" x))) +(let ((x (if (not (string-lessp emacs-version "24.4")) + "ok" + (format "Tramp 2.4.3-pre is not fit for %s" + (replace-regexp-in-string "\n" "" (emacs-version)))))) + (unless (string-equal "ok" x) (error "%s" x))) ;; Tramp versions integrated into Emacs. If a user option declares a ;; `:package-version' which doesn't belong to an integrated Tramp diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el index 40df23e174a..e297b9d6108 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el @@ -342,7 +342,7 @@ Please submit bug reports and other feedback to the author, Neil W. Van Dyke (mapconcat (lambda (c) (let ((s (char-to-string c))) (cond ((string= s " ") "+") - ((string-match "[a-zA-Z_.-/]" s) s) + ((string-match "[a-zA-Z_./~-]" s) s) (t (upcase (format "%%%02x" c)))))) (encode-coding-string str 'utf-8) "")) diff --git a/lisp/net/zeroconf.el b/lisp/net/zeroconf.el index 8c58bcc41a9..36643a828eb 100644 --- a/lisp/net/zeroconf.el +++ b/lisp/net/zeroconf.el @@ -382,6 +382,8 @@ TYPE. The resulting list has the format ;; `zeroconf-services-hash'. (gethash (concat name "/" type) zeroconf-services-hash nil)) +(defvar dbus-debug) + (defun zeroconf-resolve-service (service) "Return all service attributes SERVICE as list. NAME must be a string. The service must be of service type @@ -526,22 +528,27 @@ DOMAIN is nil, the local domain is used." zeroconf-avahi-current-domain zeroconf-avahi-flags-unspec)))) +(defvar zeroconf-service-type-browser-handler-running nil + "Prevent infinite recursion in `zeroconf-service-type-browser-handler'.") + (defun zeroconf-service-type-browser-handler (&rest val) "Registered service type browser handler at the Avahi daemon." - (when zeroconf-debug - (message "zeroconf-service-type-browser-handler: %s %S" - (dbus-event-member-name last-input-event) val)) - (cond - ((string-equal (dbus-event-member-name last-input-event) "ItemNew") - ;; Parameters: (interface protocol type domain flags) - ;; Register a service browser. - (let ((object-path (zeroconf-register-service-browser (nth 2 val)))) - ;; Register the signals. - (dolist (member '("ItemNew" "ItemRemove" "Failure")) - (dbus-register-signal - :system zeroconf-service-avahi object-path - zeroconf-interface-avahi-service-browser member - 'zeroconf-service-browser-handler)))))) + (unless zeroconf-service-type-browser-handler-running + (let ((zeroconf-service-type-browser-handler-running t)) + (when zeroconf-debug + (message "zeroconf-service-type-browser-handler: %s %S" + (dbus-event-member-name last-input-event) val)) + (cond + ((string-equal (dbus-event-member-name last-input-event) "ItemNew") + ;; Parameters: (interface protocol type domain flags) + ;; Register a service browser. + (let ((object-path (zeroconf-register-service-browser (nth 2 val)))) + ;; Register the signals. + (dolist (member '("ItemNew" "ItemRemove" "Failure")) + (dbus-register-signal + :system zeroconf-service-avahi object-path + zeroconf-interface-avahi-service-browser member + 'zeroconf-service-browser-handler)))))))) (defun zeroconf-register-service-browser (type) "Register a service browser at the Avahi daemon." |