diff options
Diffstat (limited to 'lisp/net')
-rw-r--r-- | lisp/net/ange-ftp.el | 34 | ||||
-rw-r--r-- | lisp/net/browse-url.el | 3 | ||||
-rw-r--r-- | lisp/net/imap.el | 170 | ||||
-rw-r--r-- | lisp/net/mailcap.el | 8 | ||||
-rw-r--r-- | lisp/net/newst-backend.el | 297 | ||||
-rw-r--r-- | lisp/net/pop3.el | 26 | ||||
-rw-r--r-- | lisp/net/rfc2104.el | 10 | ||||
-rw-r--r-- | lisp/net/shr-color.el | 11 | ||||
-rw-r--r-- | lisp/net/sieve-manage.el | 38 | ||||
-rw-r--r-- | lisp/net/tramp-adb.el | 122 | ||||
-rw-r--r-- | lisp/net/tramp-archive.el | 632 | ||||
-rw-r--r-- | lisp/net/tramp-cache.el | 54 | ||||
-rw-r--r-- | lisp/net/tramp-cmds.el | 23 | ||||
-rw-r--r-- | lisp/net/tramp-compat.el | 17 | ||||
-rw-r--r-- | lisp/net/tramp-gvfs.el | 527 | ||||
-rw-r--r-- | lisp/net/tramp-sh.el | 183 | ||||
-rw-r--r-- | lisp/net/tramp-smb.el | 247 | ||||
-rw-r--r-- | lisp/net/tramp.el | 403 | ||||
-rw-r--r-- | lisp/net/trampver.el | 11 |
19 files changed, 1868 insertions, 948 deletions
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index e62bee4499e..f5a5474e889 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-2018 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 @@ -1399,14 +1399,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 +1684,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 +1733,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 +1873,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 +1916,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) @@ -3404,6 +3404,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 +3445,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 @@ -3829,7 +3833,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 @@ -4385,6 +4389,8 @@ 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) @@ -4469,6 +4475,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) @@ -5199,7 +5207,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 98b0acfc0c6..8086495aaaa 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -713,8 +713,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 "[*\"()',=;?% ]")) diff --git a/lisp/net/imap.el b/lisp/net/imap.el index 3d2a4f948bc..36b96ca10af 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-2018 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 "digest-md5") +(declare-function digest-md5-digest-response "digest-md5") +(declare-function digest-md5-digest-uri "digest-md5") +(declare-function digest-md5-challenge "digest-md5") ;; User variables. @@ -1900,9 +1896,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) @@ -1956,7 +1950,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 +2139,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 +2212,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 +2453,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 +2587,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 +2596,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 +2681,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 +2710,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 +2807,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 +2873,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/mailcap.el b/lisp/net/mailcap.el index 9fbc882fdcc..748fb398933 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -1006,6 +1006,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/newst-backend.el b/lisp/net/newst-backend.el index 71a1e31d73a..520a9e19b42 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-2018 Free Software Foundation, Inc. @@ -603,7 +603,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 +639,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 +650,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 +707,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 +728,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) @@ -1255,9 +1253,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 +1288,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 +1303,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 +1338,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 +1397,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 +1478,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 +1513,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 +1750,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 +1765,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,7 +1798,7 @@ 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-less-p nil (time-add (nth 5 (file-attributes image-name)) (seconds-to-time 86400)))) (newsticker--debug-msg "%s: Getting image for %s skipped" @@ -1853,7 +1840,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 +1901,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") @@ -2008,7 +1995,7 @@ older than TIME." (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)) + (when (time-less-p exp-time nil) (newsticker--debug-msg "Item `%s' from %s has expired on %s" (newsticker--title item) @@ -2020,7 +2007,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 @@ -2293,9 +2280,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 +2348,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 +2394,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 +2486,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/pop3.el b/lisp/net/pop3.el index c2385f7f7e5..2a6807e1aca 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-2018 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) @@ -237,8 +237,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 +249,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 +269,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 +279,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 +367,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) @@ -399,7 +397,7 @@ 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)) @@ -424,7 +422,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 +438,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)) @@ -620,10 +618,8 @@ 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 (nth 8 (decode-time now)))) (when (< zone 0) - (setq sign "-") (setq zone (- zone))) (concat (format-time-string "%d" now) @@ -785,7 +781,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/rfc2104.el b/lisp/net/rfc2104.el index d974ab6a772..57bca2e8788 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-2018 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) @@ -101,7 +101,7 @@ 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)) @@ -110,8 +110,8 @@ In XEmacs return just STRING." (setq partial (rfc2104-string-make-unibyte (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))) diff --git a/lisp/net/shr-color.el b/lisp/net/shr-color.el index 60d44b3cd66..31f3d46ed66 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-2018 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" @@ -209,8 +209,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))) @@ -258,8 +258,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/sieve-manage.el b/lisp/net/sieve-manage.el index e6a1e8401d2..cd403072389 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-2018 Free Software Foundation, Inc. @@ -75,7 +75,7 @@ (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") @@ -182,7 +182,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 +206,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 +250,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 +373,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/tramp-adb.el b/lisp/net/tramp-adb.el index 0395eb4380b..f5c45f68e94 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -114,7 +114,7 @@ It is used for TCP/IP devices." (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . ignore) (file-attributes . tramp-adb-handle-file-attributes) - (file-directory-p . tramp-adb-handle-file-directory-p) + (file-directory-p . tramp-handle-file-directory-p) (file-equal-p . tramp-handle-file-equal-p) ;; FIXME: This is too sloppy. (file-executable-p . tramp-handle-file-exists-p) @@ -199,11 +199,13 @@ pass to the OPERATION." (with-temp-buffer ;; `call-process' does not react on timer under MS Windows. ;; That's why we use `start-process'. + ;; We don't know yet whether we need a user or host name for the + ;; connection vector. We assume we don't, it will be OK in most + ;; of the cases. Otherwise, there might be an additional trace + ;; buffer, which doesn't hurt. (let ((p (start-process tramp-adb-program (current-buffer) tramp-adb-program "devices")) - (v (make-tramp-file-name - :method tramp-adb-method :user tramp-current-user - :host tramp-current-host)) + (v (make-tramp-file-name :method tramp-adb-method)) result) (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " ")) (process-put p 'adjust-window-size-function 'ignore) @@ -245,16 +247,8 @@ pass to the OPERATION." ;; be problems with UNC shares or Cygwin mounts. (let ((default-directory (tramp-compat-temporary-file-directory))) (tramp-make-tramp-file-name - method user domain host port - (tramp-drop-volume-letter - (tramp-run-real-handler - 'expand-file-name (list localname)))))))) - -(defun tramp-adb-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - (eq (tramp-compat-file-attribute-type - (file-attributes (file-truename filename))) - t)) + v (tramp-drop-volume-letter + (tramp-run-real-handler 'expand-file-name (list localname)))))))) (defun tramp-adb-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." @@ -288,7 +282,7 @@ pass to the OPERATION." "%s%s" (with-parsed-tramp-file-name (expand-file-name filename) nil (tramp-make-tramp-file-name - method user domain host port + v (with-tramp-file-property v localname "file-truename" (let ((result nil)) ; result steps in reverse order (tramp-message v 4 "Finding true name for `%s'" filename) @@ -316,12 +310,10 @@ pass to the OPERATION." (tramp-compat-file-attribute-type (file-attributes (tramp-make-tramp-file-name - method user domain host port - (mapconcat 'identity - (append '("") - (reverse result) - (list thisstep)) - "/"))))) + v (mapconcat 'identity + (append + '("") (reverse result) (list thisstep)) + "/"))))) (cond ((string= "." thisstep) (tramp-message v 5 "Ignoring step `.'")) ((string= ".." thisstep) @@ -549,8 +541,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))) @@ -560,11 +552,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") @@ -575,8 +567,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))) @@ -669,8 +661,8 @@ 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)) @@ -689,26 +681,35 @@ But handle the case, if the \"test\" command is not available." (tramp-error v 'file-error "Cannot write: `%s'" filename)) (delete-file tmpfile))) - (when (or (eq visit t) (stringp visit)) - (set-visited-file-modtime)) - (unless (equal curbuf (current-buffer)) (tramp-error v 'file-error - "Buffer has changed from `%s' to `%s'" curbuf (current-buffer)))))) + "Buffer has changed from `%s' to `%s'" curbuf (current-buffer))) + + ;; 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)))) (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) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (let ((time (if (or (null time) (equal time '(0 0))) (current-time) time))) @@ -744,8 +745,8 @@ 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 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 @@ -779,8 +780,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) @@ -823,10 +825,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (tramp-error v 'file-already-exists 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 @@ -861,8 +863,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq input (with-parsed-tramp-file-name infile nil localname)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) - tmpinput (tramp-make-tramp-file-name - method user domain host port input)) + tmpinput (tramp-make-tramp-file-name v input)) (copy-file infile tmpinput t))) (when input (setq command (format "%s <%s" command input))) @@ -895,8 +896,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")))) @@ -940,7 +940,7 @@ 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) @@ -1046,7 +1046,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (or (null program) tramp-process-connection-type)) (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) (name1 name) - (i 0)) + (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. @@ -1097,8 +1099,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (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-adb-get-device (vec) "Return full host name from VEC to be used in shell execution. @@ -1107,7 +1109,7 @@ 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)) @@ -1252,10 +1254,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. @@ -1285,7 +1283,7 @@ connection if a previous connection has died for some reason." (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 'vector vec) (process-put p 'adjust-window-size-function 'ignore) (set-process-query-on-exit-flag p nil) @@ -1324,7 +1322,7 @@ 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))) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el new file mode 100644 index 00000000000..5f28756d753 --- /dev/null +++ b/lisp/net/tramp-archive.el @@ -0,0 +1,632 @@ +;;; tramp-archive.el --- Tramp archive manager -*- lexical-binding:t -*- + +;; Copyright (C) 2017-2018 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 +;; * ".mtree" - BSD mtree format +;; * ".pax" - Posix archives +;; * ".rar" - RAR archives +;; * ".rpm" - Red Hat packages +;; * ".shar" - Shell archives +;; * ".tar", "tbz", "tgz", "tlz", "txz" - (Compressed) tape archives +;; * ".warc" - Web archives +;; * ".xar" - macOS XAR archives +;; * ".xps" - Open XML Paper Specification (OpenXPS) documents +;; * ".zip", ".ZIP" - ZIP archives + +;; File archives could also be compressed, identified by an additional +;; compression suffix. Valid compression suffixes are listed in the +;; constant `tramp-archive-compression-suffixes'. They are ".bz2", +;; ".gz", ".lrz", ".lz", ".lz4", ".lzma", ".lzo", ".uu", ".xz" and +;; ".Z". A valid archive file name would be +;; "/path/to/dir/file.tar.gz/dir/file". Even several suffixes in a +;; row are possible, like "/path/to/dir/file.tar.gz.uu/dir/file". + +;; An archive file name could be a remote file name, as in +;; "/ftp:anonymous@ftp.gnu.org:/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL". +;; Since all file operations are mapped internally to GVFS operations, +;; remote file names supported by tramp-gvfs.el perform better, +;; because no local copy of the file archive must be downloaded first. +;; For example, "/sftp:user@host:..." performs better than the similar +;; "/scp:user@host:...". See the constant +;; `tramp-archive-all-gvfs-methods' for a complete list of +;; tramp-gvfs.el supported method names. + +;; If `url-handler-mode' is enabled, archives could be visited via +;; URLs, like "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL". +;; This allows complex file operations like + +;; (ediff-directories +;; "https://ftp.gnu.org/gnu/tramp/tramp-2.3.1.tar.gz/tramp-2.3.1" +;; "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/tramp-2.3.2" "") + +;; It is even possible to access file archives in file archives, as + +;; (find-file +;; "http://ftp.debian.org/debian/pool/main/c/coreutils/coreutils_8.28-1_amd64.deb/control.tar.gz/control") + +;;; Code: + +(require 'tramp-gvfs) + +(autoload 'dired-uncache "dired") +(autoload 'url-tramp-convert-url-to-tramp "url-tramp") +(defvar url-handler-mode-hook) +(defvar url-handler-regexp) +(defvar url-tramp-protocols) + +;; 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> +;;;###autoload +(defconst tramp-archive-suffixes + ;; "cab", "lzh" and "zip" are included with lower and upper letters, + ;; because Microsoft Windows provides them often with capital + ;; letters. + '("7z" ;; 7-Zip archives. + "apk" ;; Android package kits. Not in libarchive testsuite. + "ar" ;; UNIX archiver formats. + "cab" "CAB" ;; Microsoft Windows cabinets. + "cpio" ;; CPIO archives. + "deb" ;; Debian packages. Not in libarchive testsuite. + "depot" ;; HP-UX SD depot. Not in libarchive testsuite. + "exe" ;; Self extracting Microsoft Windows EXE files. + "iso" ;; ISO 9660 images. + "jar" ;; Java archives. Not in libarchive testsuite. + "lzh" "LZH" ;; Microsoft Windows compressed LHA archives. + "mtree" ;; BSD mtree format. + "pax" ;; Posix archives. + "rar" ;; RAR archives. + "rpm" ;; Red Hat packages. + "shar" ;; Shell archives. Not in libarchive testsuite. + "tar" "tbz" "tgz" "tlz" "txz" ;; (Compressed) tape archives. + "warc" ;; Web archives. + "xar" ;; macOS XAR archives. Not in libarchive testsuite. + "xps" ;; Open XML Paper Specification (OpenXPS) documents. + "zip" "ZIP") ;; ZIP archives. + "List of suffixes which indicate a file archive. +It must be supported by libarchive(3).") + +;; <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") + "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 . ignore) + (add-name-to-file . tramp-archive-handle-not-implemented) + ;; `byte-compiler-base-file-name' performed by default handler. + ;; `copy-directory' performed by default handler. + (copy-file . tramp-archive-handle-copy-file) + (delete-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) + ;; `expand-file-name' performed by default handler. + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) + (file-acl . ignore) + (file-attributes . tramp-archive-handle-file-attributes) + (file-directory-p . tramp-handle-file-directory-p) + (file-equal-p . tramp-handle-file-equal-p) + (file-executable-p . tramp-archive-handle-file-executable-p) + (file-exists-p . tramp-handle-file-exists-p) + (file-in-directory-p . tramp-handle-file-in-directory-p) + (file-local-copy . tramp-archive-handle-file-local-copy) + (file-modes . tramp-handle-file-modes) + (file-name-all-completions . tramp-archive-handle-file-name-all-completions) + ;; `file-name-as-directory' performed by default handler. + (file-name-case-insensitive-p . ignore) + (file-name-completion . tramp-handle-file-name-completion) + ;; `file-name-directory' performed by default handler. + ;; `file-name-nondirectory' performed by default handler. + ;; `file-name-sans-versions' performed by default handler. + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) + (file-notify-add-watch . ignore) + (file-notify-rm-watch . ignore) + (file-notify-valid-p . ignore) + (file-ownership-preserved-p . ignore) + (file-readable-p . tramp-archive-handle-file-readable-p) + (file-regular-p . tramp-handle-file-regular-p) + ;; `file-remote-p' performed by default handler. + (file-selinux-context . tramp-handle-file-selinux-context) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-system-info . tramp-archive-handle-file-system-info) + (file-truename . tramp-archive-handle-file-truename) + (file-writable-p . ignore) + (find-backup-file-name . ignore) + ;; `find-file-noselect' performed by default handler. + ;; `get-file-buffer' performed by default handler. + (insert-directory . tramp-archive-handle-insert-directory) + (insert-file-contents . tramp-archive-handle-insert-file-contents) + (load . tramp-archive-handle-load) + (make-auto-save-file-name . ignore) + (make-directory . tramp-archive-handle-not-implemented) + (make-directory-internal . tramp-archive-handle-not-implemented) + (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-symbolic-link . tramp-archive-handle-not-implemented) + (process-file . ignore) + (rename-file . tramp-archive-handle-not-implemented) + (set-file-acl . ignore) + (set-file-modes . tramp-archive-handle-not-implemented) + (set-file-selinux-context . ignore) + (set-file-times . tramp-archive-handle-not-implemented) + (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) + (shell-command . tramp-archive-handle-not-implemented) + (start-file-process . tramp-archive-handle-not-implemented) + ;; `substitute-in-file-name' performed by default handler. + (temporary-file-directory . tramp-archive-handle-temporary-file-directory) + (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." + (let* ((filename (apply 'tramp-archive-file-name-for-operation + operation args)) + (archive (tramp-archive-file-name-archive filename))) + ;; The file archive could be a directory, see Bug#30293. + (if (and archive + (tramp-archive-run-real-handler 'file-directory-p (list archive))) + (tramp-archive-run-real-handler operation args) + ;; Now run the handler. + (unless tramp-archive-enabled + (tramp-compat-user-error nil "Package `tramp-archive' not supported")) + (let ((tramp-methods (cons `(,tramp-archive-method) tramp-methods)) + (tramp-gvfs-methods tramp-archive-all-gvfs-methods) + ;; 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 +(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-autoload-file-name-handler)) + (put 'tramp-archive-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)) + +(eval-after-load 'url-handler + (progn + (add-hook 'url-handler-mode-hook 'tramp-register-file-name-handlers) + (add-hook + 'tramp-archive-unload-hook + (lambda () + (remove-hook + 'url-handler-mode-hook 'tramp-register-file-name-handlers))))) + + +;; File name conversions. + +(defun tramp-archive-file-name-p (name) + "Return t if NAME is a string with archive file name syntax." + (and (stringp name) + (string-match tramp-archive-file-name-regexp name) + t)) + +(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 +hexlified archive name as host, and the localname. The archive +name is kept in slot `hop'" + (save-match-data + (unless (tramp-archive-file-name-p name) + (tramp-compat-user-error nil "Not an archive file name: \"%s\"" name)) + (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 url-handler-regexp archive) + (string-match "https?" (url-type (url-generic-parse-url archive)))) + (let* ((url-tramp-protocols + (cons + (url-type (url-generic-parse-url archive)) + url-tramp-protocols)) + (archive (url-tramp-convert-url-to-tramp archive))) + (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))) + +;;;###tramp-autoload +(defun tramp-archive-cleanup-hash () + "Remove local copies of archives, used by GVFS." + (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 'kill-emacs-hook 'tramp-archive-cleanup-hash) +(add-hook 'tramp-archive-unload-hook + (lambda () + (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-copy-file + (filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Like `copy-file' for file archives." + (when (tramp-archive-file-name-p newname) + (tramp-error + (tramp-archive-dissect-file-name newname) 'file-error + "Permission denied: %s" newname)) + (copy-file + (tramp-archive-gvfs-file-name filename) newname ok-if-already-exists + keep-date preserve-uid-gid preserve-extended-attributes)) + +(defun tramp-archive-handle-directory-file-name (directory) + "Like `directory-file-name' for file archives." + (with-parsed-tramp-archive-file-name directory nil + (if (and (not (zerop (length localname))) + (eq (aref localname (1- (length localname))) ?/) + (not (string= localname "/"))) + (substring directory 0 -1) + ;; We do not want to leave the file archive. This would require + ;; unnecessary download of http-based file archives, for + ;; example. So we return `directory'. + directory))) + +(defun tramp-archive-handle-dired-uncache (dir) + "Like `dired-uncache' for file archives." + (dired-uncache (tramp-archive-gvfs-file-name dir))) + +(defun tramp-archive-handle-file-attributes (filename &optional id-format) + "Like `file-attributes' for file archives." + (file-attributes (tramp-archive-gvfs-file-name filename) id-format)) + +(defun tramp-archive-handle-file-executable-p (filename) + "Like `file-executable-p' for file archives." + (file-executable-p (tramp-archive-gvfs-file-name filename))) + +(defun tramp-archive-handle-file-local-copy (filename) + "Like `file-local-copy' for file archives." + (file-local-copy (tramp-archive-gvfs-file-name filename))) + +(defun tramp-archive-handle-file-name-all-completions (filename directory) + "Like `file-name-all-completions' for file archives." + (file-name-all-completions filename (tramp-archive-gvfs-file-name directory))) + +(defun tramp-archive-handle-file-readable-p (filename) + "Like `file-readable-p' for file archives." + (with-parsed-tramp-file-name + (tramp-archive-gvfs-file-name filename) nil + (tramp-check-cached-permissions v ?r))) + +(defun tramp-archive-handle-file-system-info (filename) + "Like `file-system-info' for file archives." + (with-parsed-tramp-archive-file-name filename nil + (list (tramp-compat-file-attribute-size (file-attributes archive)) 0 0))) + +(defun tramp-archive-handle-file-truename (filename) + "Like `file-truename' for file archives." + (with-parsed-tramp-archive-file-name filename nil + (let ((local (or (file-symlink-p filename) localname))) + (unless (file-name-absolute-p local) + (setq local (expand-file-name local (file-name-directory localname)))) + (concat (file-truename archive) local)))) + +(defun tramp-archive-handle-insert-directory + (filename switches &optional wildcard full-directory-p) + "Like `insert-directory' for file archives." + (insert-directory + (tramp-archive-gvfs-file-name filename) switches wildcard full-directory-p) + (goto-char (point-min)) + (while (search-forward (tramp-archive-gvfs-file-name filename) nil 'noerror) + (replace-match filename))) + +(defun tramp-archive-handle-insert-file-contents + (filename &optional visit beg end replace) + "Like `insert-file-contents' for file archives." + (let ((result + (insert-file-contents + (tramp-archive-gvfs-file-name filename) visit beg end replace))) + (prog1 + (list (expand-file-name filename) + (cadr result)) + (when visit (setq buffer-file-name filename))))) + +(defun tramp-archive-handle-load + (file &optional noerror nomessage nosuffix must-suffix) + "Like `load' for file archives." + (load + (tramp-archive-gvfs-file-name file) noerror nomessage nosuffix must-suffix)) + +(defun tramp-archive-handle-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 b95d2935926..97c687598f2 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -98,10 +98,7 @@ matching entries of `tramp-connection-properties'." (dolist (elt tramp-connection-properties) (when (string-match (or (nth 0 elt) "") - (tramp-make-tramp-file-name - (tramp-file-name-method key) (tramp-file-name-user key) - (tramp-file-name-domain key) (tramp-file-name-host key) - (tramp-file-name-port key) nil)) + (tramp-make-tramp-file-name key 'noloc 'nohop)) (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) hash))) @@ -117,8 +114,7 @@ Returns DEFAULT if not set." (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) @@ -169,7 +165,22 @@ 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))) @@ -184,10 +195,10 @@ 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)) @@ -206,7 +217,7 @@ Remove also properties of all files in subdirectories." ;; 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 @@ -225,7 +236,7 @@ This is suppressed for temporary buffers." (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) @@ -294,7 +305,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 @@ -387,6 +415,8 @@ used to cache connection properties of the local machine." (maphash (lambda (key value) (if (and (tramp-file-name-p key) value + (not (string-equal + (tramp-file-name-method key) tramp-archive-method)) (not (tramp-file-name-localname key)) (not (gethash "login-as" value)) (not (gethash "started" value))) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index ef9aca723de..cbb9cd37005 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -49,7 +49,7 @@ SYNTAX can be one of the symbols `default' (default), (unless (string-equal input "") (list (intern input))))) (when syntax - (custom-set-variables `(tramp-syntax ',syntax)))) + (customize-set-variable 'tramp-syntax syntax))) (defun tramp-list-tramp-buffers () "Return a list of all Tramp connection buffers." @@ -80,16 +80,7 @@ When called interactively, a Tramp connection has to be selected." ;; Return nil when there is no Tramp connection. (list (let ((connections - (mapcar - (lambda (x) - (tramp-make-tramp-file-name - (tramp-file-name-method x) - (tramp-file-name-user x) - (tramp-file-name-domain x) - (tramp-file-name-host x) - (tramp-file-name-port x) - (tramp-file-name-localname x))) - (tramp-list-connections))) + (mapcar 'tramp-make-tramp-file-name (tramp-list-connections))) name) (when connections @@ -113,13 +104,13 @@ When called interactively, a Tramp connection has to be selected." (when keep-password (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) ;; Remove buffers. (dolist @@ -152,6 +143,10 @@ This includes password cache, file cache, connection cache, buffers." ;; Flush file and connection cache. (clrhash tramp-cache-data) + ;; Cleanup local copies of archives. + (when (bound-and-true-p tramp-archive-enabled) + (tramp-archive-cleanup-hash)) + ;; Remove buffers. (dolist (name (tramp-list-tramp-buffers)) (when (bufferp (get-buffer name)) (kill-buffer name)))) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 5bf57638ff8..4f564e6eb5c 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -40,7 +40,6 @@ (require 'timer) (require 'ucs-normalize) -(require 'trampver) (require 'tramp-loaddefs) ;; For not existing functions, obsolete functions, or functions with a @@ -190,11 +189,6 @@ This is a string of ten letters or dashes as in ls -l." (if (get 'file-missing 'error-conditions) 'file-missing 'file-error) "The error symbol for the `file-missing' error.") -(add-hook 'tramp-unload-hook - (lambda () - (unload-feature 'tramp-loaddefs 'force) - (unload-feature 'tramp-compat 'force))) - ;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' are ;; introduced in Emacs 26. (eval-and-compile @@ -243,6 +237,17 @@ If NAME is a remote file name, the local part of NAME is unquoted." `(cdr (mapcar 'car (cl-struct-slot-info 'tramp-file-name))) `(cdr (mapcar 'car (get 'tramp-file-name 'cl-struct-slots))))) +;; The signature of `tramp-make-tramp-file-name' has been changed. +;; Therefore, we cannot us `url-tramp-convert-url-to-tramp' prior +;; Emacs 26.1. We use `temporary-file-directory' as indicator. +(defconst tramp-compat-use-url-tramp-p (fboundp 'temporary-file-directory) + "Whether to use url-tramp.el.") + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-loaddefs 'force) + (unload-feature 'tramp-compat 'force))) + (provide 'tramp-compat) ;;; TODO: diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index f370abba319..70ac077a7c5 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -49,15 +49,21 @@ ;; 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. +;; "davs", "gdrive", "obex", "owncloud", "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. + +;; "gdrive" and "owncloud" 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 @@ -69,7 +75,7 @@ ;; 'car ;; (dbus-call-method ;; :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker -;; tramp-gvfs-interface-mounttracker "listMountableInfo"))) +;; tramp-gvfs-interface-mounttracker "ListMountableInfo"))) ;; Note that all other connection methods are not tested, beside the ;; ones offered for customization in `tramp-gvfs-methods'. If you @@ -108,9 +114,19 @@ (eval-when-compile (require 'custom)) +;; 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.") + ;;;###tramp-autoload (defcustom tramp-gvfs-methods - '("afp" "dav" "davs" "gdrive" "obex" "sftp" "synce") + '("afp" "dav" "davs" "gdrive" "obex" "owncloud" "sftp" "synce") "List of methods for remote files, accessed with GVFS." :group 'tramp :version "26.1" @@ -119,12 +135,24 @@ (const "davs") (const "ftp") (const "gdrive") + (const "http") + (const "https") (const "obex") + (const "owncloud") (const "sftp") (const "smb") (const "synce"))) :require 'tramp) +(defconst tramp-goa-methods '("gdrive" "owncloud") + "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\\)" @@ -158,16 +186,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.") @@ -289,6 +307,162 @@ It has been changed in GVFS 1.14.") (defconst tramp-gvfs-password-anonymous-supported 16 "Operation supports anonymous users.") +;; For the time being, we just need org.goa.Account and org.goa.Files +;; interfaces. We document the other ones, just in case. + +;;;###tramp-autoload +(defconst tramp-goa-service "org.gnome.OnlineAccounts" + "The well known name of the GNOME Online Accounts service.") + +(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-goa-interface-printers "org.gnome.OnlineAccounts.Printers" + "The printers interface of the GNOME Online Accounts.") + +;; <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> +;; <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> +;; <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> + +(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> + +(defconst tramp-goa-interface-photos "org.gnome.OnlineAccounts.Photos" + "The photos interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Photos'> +;; </interface> + +(defconst tramp-goa-path-manager (concat tramp-goa-path "/Manager") + "The object path of the GNOME Online Accounts manager.") + +(defconst tramp-goa-interface-documents "org.gnome.OnlineAccounts.Manager" + "The manager interface of the GNOME Online Accounts.") + +;; <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> + +;; 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) + (defconst tramp-bluez-service "org.bluez" "The well known name of the BLUEZ service.") @@ -424,11 +598,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" @@ -473,6 +649,13 @@ Every entry is a list (NAME ADDRESS).") ":[[:blank:]]+\\(.*\\)$") "Regexp to parse GVFS file system attributes with `gvfs-info'.") +(defconst tramp-gvfs-owncloud-default-prefix "/remote.php/webdav" + "Default prefix for owncloud / nextcloud methods.") + +(defconst tramp-gvfs-owncloud-default-prefix-regexp + (concat (regexp-quote tramp-gvfs-owncloud-default-prefix) "$") + "Regexp of default prefix for owncloud / nextcloud methods.") + ;; New handlers should be added here. ;;;###tramp-autoload @@ -495,7 +678,7 @@ Every entry is a list (NAME ADDRESS).") (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . ignore) (file-attributes . tramp-gvfs-handle-file-attributes) - (file-directory-p . tramp-gvfs-handle-file-directory-p) + (file-directory-p . tramp-handle-file-directory-p) (file-equal-p . tramp-handle-file-equal-p) (file-executable-p . tramp-gvfs-handle-file-executable-p) (file-exists-p . tramp-handle-file-exists-p) @@ -604,12 +787,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) (not (consp (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)) ((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. @@ -618,22 +813,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)) (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 @@ -642,7 +849,7 @@ is no information where to trace the message.") (defun tramp-gvfs-dbus-event-error (event err) "Called when a D-Bus error message arrives, see `dbus-event-error-functions'." (when tramp-gvfs-dbus-event-vector - (tramp-message tramp-gvfs-dbus-event-vector 10 "%S" event) + (tramp-message tramp-gvfs-dbus-event-vector 6 "%S" event) (tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err)))) ;; `dbus-event-error-hooks' has been renamed to @@ -675,6 +882,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) @@ -738,13 +946,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 @@ -778,8 +986,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") @@ -793,8 +1001,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") @@ -1043,11 +1251,6 @@ If FILE-SYSTEM is non-nil, return file system attributes." res-device ))))) -(defun tramp-gvfs-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - (eq t (tramp-compat-file-attribute-type - (file-attributes (file-truename filename))))) - (defun tramp-gvfs-handle-file-executable-p (filename) "Like `file-executable-p' for Tramp files." (with-parsed-tramp-file-name filename nil @@ -1101,14 +1304,14 @@ If FILE-SYSTEM is non-nil, return file system attributes." '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)) + `("gvfs-monitor-file" (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) + (process-put p 'vector v) (process-put p 'events events) (process-put p 'watch-name localname) (process-put p 'adjust-window-size-function 'ignore) @@ -1119,7 +1322,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (tramp-accept-process-output p 1) (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) @@ -1178,7 +1381,7 @@ file-notify events." (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))) @@ -1203,8 +1406,8 @@ file-notify events." "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 @@ -1260,8 +1463,8 @@ file-notify events." (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) + (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)) @@ -1270,7 +1473,8 @@ file-notify events." (file-attributes filename)))) ;; The end. - (when (or (eq visit t) (null visit) (stringp visit)) + (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))) @@ -1290,6 +1494,10 @@ file-notify events." (with-parsed-tramp-file-name filename nil (when (string-equal "gdrive" method) (setq method "google-drive")) + (when (string-equal "owncloud" 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 @@ -1314,24 +1522,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. @@ -1363,13 +1553,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. @@ -1408,7 +1592,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 "" @@ -1449,6 +1633,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 @@ -1464,31 +1649,35 @@ 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 + tramp-gvfs-owncloud-default-prefix-regexp prefix)) + (setq method "owncloud")) (when (string-equal "google-drive" method) (setq method "gdrive")) + (when (and (string-equal "http" method) (stringp uri)) + (setq uri (url-generic-parse-url uri) + method (url-type uri) + user (url-user uri) + host (url-host uri) + port (url-portspec uri))) (with-parsed-tramp-file-name (tramp-make-tramp-file-name method user domain host port "") nil (tramp-message v 6 "%s %s" signal-name (tramp-gvfs-stringify-dbus-message mount-info)) - (tramp-set-file-property v "/" "list-mounts" 'undef) + (tramp-flush-file-property v "/" "list-mounts") (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-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))))))) @@ -1531,6 +1720,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 @@ -1546,39 +1736,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 + tramp-gvfs-owncloud-default-prefix-regexp prefix)) + (setq method "owncloud")) (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)) + (string-match (concat "^/" (regexp-quote (or share ""))) (tramp-file-name-unquote-localname vec))) - ;; Set prefix, mountpoint and location. - (unless (string-equal prefix "/") - (tramp-set-file-property vec "/" "prefix" prefix)) + ;; 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})\"." @@ -1597,7 +1807,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 "^davs\\|^owncloud" method) "true" "false")) (mount-spec `(:array ,@(cond @@ -1609,7 +1819,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (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 "^dav\\|^owncloud" method) (list (tramp-gvfs-mount-spec-entry "type" "dav") (tramp-gvfs-mount-spec-entry "host" host) (tramp-gvfs-mount-spec-entry "ssl" ssl))) @@ -1620,7 +1830,14 @@ It was \"a(say)\", but has changed to \"a{sv})\"." ((string-equal "gdrive" method) (list (tramp-gvfs-mount-spec-entry "type" "google-drive") (tramp-gvfs-mount-spec-entry "host" host))) - (t + ((string-match "^http" method) + (list (tramp-gvfs-mount-spec-entry "type" "http") + (tramp-gvfs-mount-spec-entry + "uri" + (url-recreate-url + (url-parse-make-urlobj + method user nil host port "/" nil nil t))))) + (t (list (tramp-gvfs-mount-spec-entry "type" method) (tramp-gvfs-mount-spec-entry "host" host)))) ,@(when user @@ -1630,10 +1847,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 "^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))) @@ -1685,6 +1902,21 @@ ID-FORMAT valid values are `string' and `integer'." (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 + (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)) + "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 @@ -1701,6 +1933,7 @@ connection if a previous connection has died for some reason." :name (tramp-buffer-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) @@ -1746,7 +1979,8 @@ connection if a previous connection has died for some reason." tramp-gvfs-interface-mountoperation "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" @@ -1836,11 +2070,84 @@ is applied, and it returns t if the return code is zero." (erase-buffer) (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 GNOME Online Accounts functions. + +(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." + (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")) + ;; 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:///")))))))))) ;; D-Bus BLUEZ functions. +(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))))))) + (defun tramp-bluez-list-devices () "Return all discovered bluetooth devices as list. Every entry is a list (NAME ADDRESS). @@ -2042,6 +2349,8 @@ They are retrieved from the hal daemon." ;;; TODO: +;; * (Customizable) unmount when exiting Emacs. See tramp-archive.el. + ;; * Host name completion for existing mount points (afp-server, ;; smb-server) or via smb-network. ;; diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 9b74da65805..5204ec725a3 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1104,8 +1104,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 @@ -1500,8 +1500,8 @@ of." (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 @@ -1512,8 +1512,8 @@ 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) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (let ((time (if (or (null time) (equal time '(0 0))) (current-time) time))) @@ -1605,8 +1605,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) @@ -1646,7 +1645,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. @@ -1940,8 +1939,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 @@ -2007,8 +2006,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) @@ -2133,14 +2132,16 @@ file names." ;; 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. @@ -2362,15 +2363,6 @@ The method used must be an out-of-band method." (expand-file-name ".." tmpfile) 'recursive) (delete-file tmpfile))))) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method (tramp-file-name-method v) - tramp-current-user (or (tramp-file-name-user v) - (tramp-get-connection-property - v "login-as" nil)) - tramp-current-domain (tramp-file-name-domain v) - tramp-current-host (tramp-file-name-host v) - tramp-current-port (tramp-file-name-port v)) - ;; Check which ones of source and target are Tramp files. (setq source (funcall (if (and (file-directory-p filename) @@ -2481,7 +2473,9 @@ 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))) + (process-environment (copy-sequence process-environment)) + ;; We do not want to run timers. + timer-list timer-idle-list) ;; Set the transfer process properties. (tramp-set-connection-property v "process-name" (buffer-name (current-buffer))) @@ -2513,7 +2507,7 @@ 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 'vector orig-vec) (process-put p 'adjust-window-size-function 'ignore) (set-process-query-on-exit-flag p nil) @@ -2524,8 +2518,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))) @@ -2556,7 +2550,7 @@ 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)) + (tramp-flush-directory-properties v (file-name-directory localname)) (save-excursion (tramp-barf-unless-okay v (format "%s %s" @@ -2568,8 +2562,8 @@ The method used must be an out-of-band method." "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)) @@ -2581,8 +2575,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") @@ -2595,7 +2589,7 @@ 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) + (tramp-flush-file-properties v localname) (save-excursion (let ((suffixes dired-compress-file-suffixes) suffix) @@ -2828,11 +2822,11 @@ the result will be a local, non-Tramp, file name." (defun tramp-process-sentinel (proc event) "Flush file caches." (unless (process-live-p proc) - (let ((vec (tramp-get-connection-property proc "vector" nil))) + (let ((vec (process-get proc 'vector))) (when vec (tramp-message vec 5 "Sentinel called: `%S' `%s'" proc event) - (tramp-flush-connection-property proc) - (tramp-flush-directory-property vec ""))))) + (tramp-flush-connection-properties proc) + (tramp-flush-directory-properties vec ""))))) ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once @@ -2866,13 +2860,7 @@ the result will be a local, non-Tramp, file name." ;; We discard hops, if existing, that's why we cannot use ;; `file-remote-p'. (prompt (format "PS1=%s %s" - (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-domain v) - (tramp-file-name-host v) - (tramp-file-name-port v) - (tramp-file-name-localname v)) + (tramp-make-tramp-file-name v nil 'nohop) tramp-initial-end-of-output)) ;; We use as environment the difference to toplevel ;; `process-environment'. @@ -2908,7 +2896,9 @@ the result will be a local, non-Tramp, file name." ;; We do not want to raise an error when ;; `start-file-process' has been started several times in ;; `eshell' and friends. - (tramp-current-connection nil) + tramp-current-connection + ;; We do not want to run timers. + timer-list timer-idle-list p) (while (get-process name1) @@ -2972,8 +2962,8 @@ the result will be a local, non-Tramp, file name." (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)))))) + (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) @@ -3095,7 +3085,7 @@ 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) @@ -3399,8 +3389,8 @@ the result will be a local, non-Tramp, file name." (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. @@ -3420,7 +3410,8 @@ the result will be a local, non-Tramp, file name." ;; Set the ownership. (when need-chown (tramp-set-file-uid-gid filename uid gid)) - (when (or (eq visit t) (null visit) (stringp visit)) + (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))))) @@ -3572,19 +3563,7 @@ 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 events @@ -3602,6 +3581,20 @@ 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)))) + ;; "gvfs-monitor-dir" or "gio monitor". + ((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 (if (string-match "/gio$" command) + `(,command "monitor" ,localname) + `(,command ,localname)))) ;; None. (t (tramp-error v 'file-notify-error @@ -3621,7 +3614,7 @@ Fall back to normal file name handler if no Tramp handler exists." "`%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) + (process-put p 'vector v) ;; Needed for process filter. (process-put p 'events events) (process-put p 'watch-name localname) @@ -3632,7 +3625,7 @@ Fall back to normal file name handler if no Tramp handler exists." (tramp-accept-process-output p 1) (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-gvfs-monitor-dir-process-filter (proc string) @@ -3650,7 +3643,8 @@ 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) + ;; https://bugs.launchpad.net/bugs/1742946 + (when (string-match "Monitoring not supported\\|No locations given" string) (delete-process proc)) (while (string-match @@ -4036,7 +4030,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 @@ -4124,7 +4118,7 @@ process to set up. VEC specifies the connection." (memq 'utf-8-hfs (coding-system-list))) (setq cs-decode 'utf-8-hfs cs-encode 'utf-8-hfs)) - (set-buffer-process-coding-system cs-decode cs-encode) + (set-process-coding-system proc cs-decode cs-encode) (tramp-message vec 5 "Setting coding system to `%s' and `%s'" cs-decode cs-encode))) @@ -4470,13 +4464,14 @@ Goes through the list `tramp-inline-compress-commands'." (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. - (if (memq system-type '(windows-nt)) - "echo %s | \"%s\" | \"%s\"" - "echo %s | %s | %s") - magic compress decompress) + (mapconcat + 'shell-quote-argument (split-string compress) " ") + (mapconcat + 'shell-quote-argument (split-string decompress) " ")) nil nil)) (throw 'next nil)) (tramp-message @@ -4727,7 +4722,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)) @@ -4750,13 +4746,12 @@ 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 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) " ")) @@ -4810,16 +4805,16 @@ connection if a previous connection has died for some reason." ;; Check, whether there is a restricted shell. (dolist (elt tramp-restricted-shell-hosts-alist) - (when (string-match elt tramp-current-host) + (when (string-match elt current-host) (setq r-shell t))) + (setq current-host l-host) - ;; Set variables for computing the prompt for - ;; reading password. - (setq tramp-current-method l-method - tramp-current-user l-user - tramp-current-domain l-domain - tramp-current-host l-host - tramp-current-port l-port) + ;; Set password prompt vector. + (tramp-set-connection-property + p "password-vector" + (make-tramp-file-name + :method l-method :user l-user :domain l-domain + :host l-host :port l-port)) ;; Add login environment. (when login-env @@ -5244,14 +5239,7 @@ Nonexistent directories are removed from spec." (lambda (x) (and (stringp x) - (file-directory-p - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - x)) + (file-directory-p (tramp-make-tramp-file-name vec x)) x)) remote-path))))) @@ -5478,7 +5466,8 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." ;; We distinguish "gvfs-monitor-dir.exe" from cygwin in order to ;; establish better timeouts in filenotify-tests.el. Any better ;; distinction approach would be welcome! - (or (tramp-find-executable + (or (tramp-find-executable vec "gio" (tramp-get-remote-path vec) t t) + (tramp-find-executable vec "gvfs-monitor-dir.exe" (tramp-get-remote-path vec) t t) (tramp-find-executable vec "gvfs-monitor-dir" (tramp-get-remote-path vec) t t)))) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 59db6ee6071..eab0da54b6d 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -151,6 +151,7 @@ call, letting the SMB client use the default one." "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_SHARING_VIOLATION" "NT_STATUS_TRUSTED_RELATIONSHIP_FAILURE" "NT_STATUS_UNSUCCESSFUL" @@ -228,10 +229,10 @@ See `tramp-actions-before-shell' for more info.") (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (expand-file-name . tramp-smb-handle-expand-file-name) - (file-accessible-directory-p . tramp-smb-handle-file-directory-p) + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . tramp-smb-handle-file-acl) (file-attributes . tramp-smb-handle-file-attributes) - (file-directory-p . tramp-smb-handle-file-directory-p) + (file-directory-p . tramp-handle-file-directory-p) (file-file-equal-p . tramp-handle-file-equal-p) (file-executable-p . tramp-handle-file-exists-p) (file-exists-p . tramp-handle-file-exists-p) @@ -370,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 @@ -449,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 @@ -464,7 +458,9 @@ pass to the OPERATION." (expand-file-name tramp-temp-name-prefix (tramp-compat-temporary-file-directory)))) - (args (list (concat "//" host "/" share) "-E"))) + (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))) @@ -524,7 +520,7 @@ pass to the OPERATION." (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" v) + (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) @@ -534,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. @@ -552,8 +548,8 @@ 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 @@ -598,8 +594,8 @@ 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) (unless (tramp-smb-get-share v) (tramp-error v 'file-error "Target `%s' must contain a share name" newname)) @@ -633,8 +629,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\"" @@ -654,8 +650,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\"" @@ -739,62 +735,58 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (defun tramp-smb-handle-file-acl (filename) "Like `file-acl' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-tramp-file-property v localname "file-acl" - (when (executable-find tramp-smb-acl-program) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - - (let* ((share (tramp-smb-get-share v)) - (localname (replace-regexp-in-string - "\\\\" "/" (tramp-smb-get-localname v))) - (args (list (concat "//" host "/" share) "-E"))) - - (if (not (zerop (length user))) - (setq args (append args (list "-U" user))) - (setq args (append args (list "-N")))) - - (when domain (setq args (append args (list "-W" domain)))) - (when port (setq args (append args (list "-p" port)))) - (when tramp-smb-conf - (setq args (append args (list "-s" tramp-smb-conf)))) - (setq - args - (append args (list (tramp-unquote-shell-quote-argument localname) - "2>/dev/null"))) - - (unwind-protect - (with-temp-buffer - ;; Set the transfer process properties. - (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) - (tramp-set-connection-property - v "process-buffer" (current-buffer)) - - ;; Use an asynchronous processes. By this, password - ;; can be handled. - (let ((p (apply - 'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - tramp-smb-acl-program args))) - - (tramp-message - v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" v) - (process-put p 'adjust-window-size-function 'ignore) - (set-process-query-on-exit-flag p nil) - (tramp-process-actions p v nil tramp-smb-actions-get-acl) - (when (> (point-max) (point-min)) - (substring-no-properties (buffer-string))))) - - ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil))))))) + (ignore-errors + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-acl" + (when (executable-find tramp-smb-acl-program) + (let* ((share (tramp-smb-get-share v)) + (localname (replace-regexp-in-string + "\\\\" "/" (tramp-smb-get-localname v))) + (args (list (concat "//" host "/" share) "-E")) + ;; 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 process. By this, password can + ;; be handled. + (let ((p (apply + 'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + tramp-smb-acl-program args))) + + (tramp-message + v 6 "%s" (mapconcat 'identity (process-command p) " ")) + (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." @@ -911,13 +903,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 @@ -1164,8 +1149,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (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)) + (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)))))) @@ -1211,8 +1196,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 @@ -1222,7 +1207,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) @@ -1235,6 +1220,8 @@ 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. @@ -1327,14 +1314,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) @@ -1370,10 +1357,10 @@ 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 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) + (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)) @@ -1403,21 +1390,17 @@ 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)))) + "\n" "," acl-string))) + ;; We do not want to run timers. + timer-list timer-idle-list) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -1451,7 +1434,7 @@ component is used as the target of the symlink." (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" v) + (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) @@ -1470,14 +1453,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 @@ -1497,7 +1480,9 @@ component is used as the target of the symlink." (command (mapconcat 'identity (cons program args) " ")) (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) (name1 name) - (i 0)) + (i 0) + ;; We do not want to run timers. + timer-list timer-idle-list) (unwind-protect (save-excursion (save-restriction @@ -1530,8 +1515,8 @@ component is used as the target of the symlink." (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. @@ -1564,8 +1549,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)) @@ -1589,9 +1574,18 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (tramp-error v 'file-error "Buffer has changed from `%s' to `%s'" curbuf (current-buffer))) - (when (eq visit t) - (set-visited-file-modtime))))) + ;; 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)))) ;; Internal file name functions. @@ -1889,8 +1883,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))) @@ -1967,17 +1961,10 @@ If ARGUMENT is non-nil, use it as argument for (tramp-message vec 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" vec) + (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. @@ -1998,8 +1985,8 @@ If ARGUMENT is non-nil, use it as argument for smbserver-version (tramp-get-connection-property vec "smbserver-version" smbserver-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 "smbserver-version" smbserver-version)))) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index c4839e7f697..b2e20000d3f 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -56,6 +56,7 @@ ;;; Code: (require 'tramp-compat) +(require 'trampver) ;; Pacify byte-compiler. (require 'cl-lib) @@ -349,7 +350,7 @@ This variable is regarded as obsolete, and will be removed soon." "Default user to use for specific method/host pairs. This is an alist of items (METHOD HOST USER). The first matching item specifies the user to use for a file name which does not specify a -user. METHOD and USER are regular expressions or nil, which is +user. METHOD and HOST are regular expressions or nil, which is interpreted as a regular expression which always matches. If no entry matches, the variable `tramp-default-user' takes effect. @@ -373,7 +374,7 @@ Useful for su and sudo methods mostly." "Default host to use for specific method/user pairs. This is an alist of items (METHOD USER HOST). The first matching item specifies the host to use for a file name which does not specify a -host. METHOD and HOST are regular expressions or nil, which is +host. METHOD and USER are regular expressions or nil, which is interpreted as a regular expression which always matches. If no entry matches, the variable `tramp-default-host' takes effect. @@ -1182,21 +1183,6 @@ means to use always cached values for the directory contents." ;;; Internal Variables: -(defvar tramp-current-method nil - "Connection method for this *tramp* buffer.") - -(defvar tramp-current-user nil - "Remote login name for this *tramp* buffer.") - -(defvar tramp-current-domain nil - "Remote domain name for this *tramp* buffer.") - -(defvar tramp-current-host nil - "Remote host for this *tramp* buffer.") - -(defvar tramp-current-port nil - "Remote port for this *tramp* buffer.") - (defvar tramp-current-connection nil "Last connection timestamp.") @@ -1390,7 +1376,7 @@ values." (make-tramp-file-name :method method :user user :domain domain :host host :port port - :localname (or localname "") :hop hop))))) + :localname localname :hop hop))))) (defun tramp-buffer-name (vec) "A name for the connection buffer VEC." @@ -1401,30 +1387,65 @@ values." (format "*tramp/%s %s@%s*" method user-domain host-port) (format "*tramp/%s %s*" method host-port)))) -(defun tramp-make-tramp-file-name - (method user domain host port localname &optional hop) - "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME. -When not nil, optional DOMAIN, PORT and HOP are used." - (concat tramp-prefix-format hop - (unless (or (zerop (length method)) - (zerop (length tramp-postfix-method-format))) - (concat method tramp-postfix-method-format)) - user - (unless (zerop (length domain)) - (concat tramp-prefix-domain-format domain)) - (unless (zerop (length user)) - tramp-postfix-user-format) - (when host - (if (string-match tramp-ipv6-regexp host) - (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) - host)) - (unless (zerop (length port)) - (concat tramp-prefix-port-format port)) - tramp-postfix-host-format - (when localname localname))) +(defun tramp-make-tramp-file-name (&rest args) + "Construct a Tramp file name from ARGS. + +ARGS could have two different signatures. The first one is of +type (VEC &optional LOCALNAME HOP). +If LOCALNAME is nil, the value in VEC is used. If it is a +symbol, a null localname will be used. Otherwise, LOCALNAME is +expected to be a string, which will be used. +If HOP is nil, the value in VEC is used. If it is a symbol, a +null hop will be used. Otherwise, HOP is expected to be a +string, which will be used. + +The other signature exists for backward compatibility. It has +the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." + (let (method user domain host port localname hop) + (cond + ((tramp-file-name-p (car args)) + (setq method (tramp-file-name-method (car args)) + user (tramp-file-name-user (car args)) + domain (tramp-file-name-domain (car args)) + host (tramp-file-name-host (car args)) + port (tramp-file-name-port (car args)) + localname (tramp-file-name-localname (car args)) + hop (tramp-file-name-hop (car args))) + (when (cadr args) + (setq localname (and (stringp (cadr args)) (cadr args)))) + (when (cl-caddr args) + (setq hop (and (stringp (cl-caddr args)) (cl-caddr args))))) + + (t (setq method (nth 0 args) + user (nth 1 args) + domain (nth 2 args) + host (nth 3 args) + port (nth 4 args) + localname (nth 5 args) + hop (nth 6 args)))) + + (when (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 + localname))) (defun tramp-completion-make-tramp-file-name (method user host localname) - "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME. + "Construct a Tramp file name from METHOD, USER, HOST and LOCALNAME. It must not be a complete Tramp file name, but as long as there are necessary only. This function will be used in file name completion." (concat tramp-prefix-format @@ -1451,15 +1472,8 @@ necessary only. This function will be used in file name completion." (tramp-set-connection-property vec "process-buffer" (tramp-get-connection-property vec "process-buffer" nil)) - (setq buffer-undo-list t) - (setq default-directory - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - "/")) + (setq buffer-undo-list t + default-directory (tramp-make-tramp-file-name vec "/" 'nohop)) (current-buffer)))) (defun tramp-get-connection-buffer (vec) @@ -1545,7 +1559,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. + (set-keymap-parent (current-local-map) special-mode-map)) (current-buffer))) (defsubst tramp-debug-message (vec fmt-string &rest arguments) @@ -1614,10 +1630,11 @@ ARGUMENTS to actually emit the message (if applicable)." ;; The message. (insert (apply #'format-message fmt-string arguments)))) -(defvar tramp-message-show-message t +(defvar tramp-message-show-message (null noninteractive) "Show Tramp message in the minibuffer. -This variable is used to disable messages from `tramp-error'. -The messages are visible anyway, because an error is raised.") +This variable is used to suppress progress reporter output, and +to disable messages from `tramp-error'. Those messages are +visible anyway, because an error is raised.") (defsubst tramp-message (vec-or-proc level fmt-string &rest arguments) "Emit a message depending on verbosity level. @@ -1649,17 +1666,18 @@ applicable)." 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)))) - ;; Append connection buffer for error messages. - (when (= level 1) - (let ((tramp-verbose 0)) - (with-current-buffer (tramp-get-connection-buffer vec-or-proc) + (let ((tramp-verbose 0)) + ;; Append connection buffer for error messages. + (when (= level 1) + (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))))))) + 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 @@ -2052,6 +2070,7 @@ pass to the OPERATION." `(tramp-file-name-handler tramp-vc-file-name-handler tramp-completion-file-name-handler + tramp-archive-file-name-handler cygwin-mount-name-hook-function cygwin-mount-map-drive-hook-function . @@ -2217,6 +2236,8 @@ Falls back to normal file name handler if no Tramp file name handler exists." (let ((default-directory (tramp-compat-temporary-file-directory))) (load (cadr sf) 'noerror 'nomessage))) +;; (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 @@ -2240,6 +2261,8 @@ Falls back to normal file name handler if no Tramp file name handler exists." (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 @@ -2352,15 +2375,19 @@ remote file names." (defun tramp-register-file-name-handlers () "Add Tramp file name handlers to `file-name-handler-alist'." ;; Remove autoloaded handlers from file name handler alist. Useful, - ;; if `tramp-syntax' has been changed. + ;; if `tramp-syntax' has been changed. We cannot call + ;; `tramp-unload-file-name-handlers', this would result in recursive + ;; loading of Tramp. (dolist (fnh '(tramp-file-name-handler tramp-completion-file-name-handler + tramp-archive-file-name-handler tramp-autoload-file-name-handler)) (let ((a1 (rassq fnh file-name-handler-alist))) (setq file-name-handler-alist (delq a1 file-name-handler-alist)))) ;; Add the handlers. We do not add anything to the `operations' - ;; property of `tramp-file-name-handler', this shall be done by the + ;; property of `tramp-file-name-handler' and + ;; `tramp-archive-file-name-handler', this shall be done by the ;; respective foreign handlers. (add-to-list 'file-name-handler-alist (cons tramp-file-name-regexp 'tramp-file-name-handler)) @@ -2374,6 +2401,12 @@ remote file names." (put 'tramp-completion-file-name-handler 'operations (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'. (dolist (fnh '(epa-file-handler jka-compr-handler)) @@ -2427,6 +2460,7 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." "Unload Tramp file name handlers from `file-name-handler-alist'." (dolist (fnh '(tramp-file-name-handler tramp-completion-file-name-handler + tramp-archive-file-name-handler tramp-autoload-file-name-handler)) (let ((a1 (rassq fnh file-name-handler-alist))) (setq file-name-handler-alist (delq a1 file-name-handler-alist)))))) @@ -2488,7 +2522,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. @@ -2926,8 +2959,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))) @@ -2971,13 +3004,19 @@ 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-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 @@ -3018,17 +3057,11 @@ User is always nil." ;; Run the command on the localname portion only unless we are in ;; completion mode. (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-domain v) - (tramp-file-name-host v) - (tramp-file-name-port v) - (if (and (zerop (length (tramp-file-name-localname v))) - (not (tramp-connectable-p file))) - "" - (tramp-run-real-handler - 'file-name-as-directory (list (or (tramp-file-name-localname v) "")))) - (tramp-file-name-hop v)))) + v (unless (and (zerop (length (tramp-file-name-localname v))) + (not (tramp-connectable-p file))) + (tramp-run-real-handler + 'file-name-as-directory + (list (or (tramp-file-name-localname v) ""))))))) (defun tramp-handle-file-name-case-insensitive-p (filename) "Like `file-name-case-insensitive-p' for Tramp files." @@ -3087,10 +3120,6 @@ User is always nil." (defun tramp-handle-file-name-completion (filename directory &optional predicate) "Like `file-name-completion' for Tramp files." - (unless (tramp-tramp-file-p directory) - (error - "tramp-handle-file-name-completion invoked on non-tramp directory `%s'" - directory)) (let (hits-ignored-extensions) (or (try-completion @@ -3116,14 +3145,8 @@ User is always nil." (let ((v (tramp-dissect-file-name file t))) ;; Run the command on the localname portion only. (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-domain v) - (tramp-file-name-host v) - (tramp-file-name-port v) - (tramp-run-real-handler - 'file-name-directory (list (or (tramp-file-name-localname v) ""))) - (tramp-file-name-hop v)))) + v (tramp-run-real-handler + 'file-name-directory (list (or (tramp-file-name-localname v) "")))))) (defun tramp-handle-file-name-nondirectory (file) "Like `file-name-nondirectory' but aware of Tramp files." @@ -3162,7 +3185,8 @@ User is always nil." (and (or (not connected) c) (cond ((eq identification 'method) method) - ;; Domain and port are appended. + ;; Domain and port are appended to user and host, + ;; respectively. ((eq identification 'user) (tramp-file-name-user-domain v)) ((eq identification 'host) (tramp-file-name-host-port v)) ((eq identification 'localname) localname) @@ -3530,17 +3554,19 @@ 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. (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 (substitute-in-file-name localname)) + (setq filename + (concat (file-remote-p filename) + (substitute-in-file-name localname)))))) + ;; "/m:h:~" does not work for completion. We use "/m:h:~/". + (if (string-match "~$" filename) + (concat filename "/") + filename)))) (defun tramp-handle-set-visited-file-modtime (&optional time-list) "Like `set-visited-file-modtime' for Tramp files." @@ -3574,29 +3600,28 @@ of." (eq (visited-file-modtime) 0) (not (file-remote-p f nil 'connected))) t - (with-parsed-tramp-file-name f nil - (let* ((remote-file-name-inhibit-cache t) - (attr (file-attributes f)) - (modtime (tramp-compat-file-attribute-modification-time attr)) - (mt (visited-file-modtime))) - - (cond - ;; File exists, and has a known modtime. - ((and attr (not (equal modtime '(0 0)))) - (< (abs (tramp-time-diff - modtime - ;; For compatibility, deal with both the old - ;; (HIGH . LOW) and the new (HIGH LOW) return - ;; values of `visited-file-modtime'. - (if (atom (cdr mt)) - (list (car mt) (cdr mt)) - mt))) - 2)) - ;; Modtime has the don't know value. - (attr t) - ;; If file does not exist, say it is not modified if and - ;; only if that agrees with the buffer's record. - (t (equal mt '(-1 65535)))))))))) + (let* ((remote-file-name-inhibit-cache t) + (attr (file-attributes f)) + (modtime (tramp-compat-file-attribute-modification-time attr)) + (mt (visited-file-modtime))) + + (cond + ;; File exists, and has a known modtime. + ((and attr (not (equal modtime '(0 0)))) + (< (abs (tramp-time-diff + modtime + ;; For compatibility, deal with both the old + ;; (HIGH . LOW) and the new (HIGH LOW) return + ;; values of `visited-file-modtime'. + (if (atom (cdr mt)) + (list (car mt) (cdr mt)) + mt))) + 2)) + ;; Modtime has the don't know value. + (attr t) + ;; If file does not exist, say it is not modified if and + ;; only if that agrees with the buffer's record. + (t (equal mt '(-1 65535))))))))) (defun tramp-handle-file-notify-add-watch (filename _flags _callback) "Like `file-notify-add-watch' for Tramp files." @@ -3633,17 +3658,16 @@ of." (defun tramp-action-login (_proc vec) "Send the login name." - (when (not (stringp tramp-current-user)) - (setq tramp-current-user - (with-tramp-connection-property vec "login-as" - (save-window-excursion - (let ((enable-recursive-minibuffers t)) - (pop-to-buffer (tramp-get-connection-buffer vec)) - (read-string (match-string 0))))))) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) - (tramp-message vec 3 "Sending login name `%s'" tramp-current-user) - (tramp-send-string vec (concat tramp-current-user tramp-local-end-of-line))) + (let ((user (or (tramp-file-name-user vec) + (with-tramp-connection-property vec "login-as" + (save-window-excursion + (let ((enable-recursive-minibuffers t)) + (pop-to-buffer (tramp-get-connection-buffer vec)) + (read-string (match-string 0)))))))) + (with-current-buffer (tramp-get-connection-buffer vec) + (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message vec 3 "Sending login name `%s'" user) + (tramp-send-string vec (concat user tramp-local-end-of-line)))) (defun tramp-action-password (proc vec) "Query the user for a password." @@ -3767,12 +3791,10 @@ PROC and VEC indicate the remote connection to be used. POS, if set, is the starting point of the region to be deleted in the connection buffer." ;; Enable `auth-source', unless "emacs -Q" has been called. We must - ;; use `tramp-current-*' variables in case we have several hops. + ;; use the "password-vector" property in case we have several hops. (tramp-set-connection-property - (make-tramp-file-name - :method tramp-current-method :user tramp-current-user - :domain tramp-current-domain :host tramp-current-host - :port tramp-current-port) + (tramp-get-connection-property + proc "password-vector" (process-get proc 'vector)) "first-password-request" tramp-cache-read-persistent-data) (save-restriction (with-tramp-progress-reporter @@ -3823,7 +3845,9 @@ connection buffer." 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) + (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 @@ -4140,15 +4164,7 @@ be granted." vec (tramp-file-name-localname vec) (concat "file-attributes-" suffix) nil) (file-attributes - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - (tramp-file-name-localname vec) - (tramp-file-name-hop vec)) - (intern suffix)))) + (tramp-make-tramp-file-name vec) (intern suffix)))) (remote-uid (tramp-get-connection-property vec (concat "uid-" suffix) nil)) @@ -4205,11 +4221,7 @@ be granted." ;; The local temp directory must be writable for the other user. (file-writable-p (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - host port - (tramp-compat-temporary-file-directory))) + vec (tramp-compat-temporary-file-directory) 'nohop)) ;; On some systems, chown runs only for root. (or (zerop (user-uid)) ;; This is defined in tramp-sh.el. Let's assume this is @@ -4219,14 +4231,9 @@ be granted." (defun tramp-get-remote-tmpdir (vec) "Return directory for temporary files on the remote host identified by VEC." (with-tramp-connection-property vec "tmpdir" - (let ((dir (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp") - (tramp-file-name-hop vec)))) + (let ((dir + (tramp-make-tramp-file-name + vec (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp")))) (or (and (file-directory-p dir) (file-writable-p dir) (file-remote-p dir 'localname)) (tramp-error vec 'file-error "Directory %s not accessible" dir)) @@ -4339,15 +4346,10 @@ It always returns a return code. The Lisp error raised when PROGRAM is nil is trapped also, returning 1. Furthermore, traces are written with verbosity of 6." (let ((default-directory (tramp-compat-temporary-file-directory)) - (v (or vec - (make-tramp-file-name - :method tramp-current-method :user tramp-current-user - :domain tramp-current-domain :host tramp-current-host - :port tramp-current-port))) (destination (if (eq destination t) (current-buffer) destination)) output error result) (tramp-message - v 6 "`%s %s' %s %s" + vec 6 "`%s %s' %s %s" program (mapconcat 'identity args " ") infile destination) (condition-case err (with-temp-buffer @@ -4365,8 +4367,8 @@ are written with verbosity of 6." (setq error (error-message-string err) result 1))) (if (zerop (length error)) - (tramp-message v 6 "%d\n%s" result output) - (tramp-message v 6 "%d\n%s\n%s" result output error)) + (tramp-message vec 6 "%d\n%s" result output) + (tramp-message vec 6 "%d\n%s\n%s" result output error)) result)) (defun tramp-call-process-region @@ -4376,15 +4378,10 @@ It always returns a return code. The Lisp error raised when PROGRAM is nil is trapped also, returning 1. Furthermore, traces are written with verbosity of 6." (let ((default-directory (tramp-compat-temporary-file-directory)) - (v (or vec - (make-tramp-file-name - :method tramp-current-method :user tramp-current-user - :domain tramp-current-domain :host tramp-current-host - :port tramp-current-port))) (buffer (if (eq buffer t) (current-buffer) buffer)) result) (tramp-message - v 6 "`%s %s' %s %s %s %s" + vec 6 "`%s %s' %s %s %s %s" program (mapconcat 'identity args " ") start end delete buffer) (condition-case err (progn @@ -4397,11 +4394,11 @@ are written with verbosity of 6." (signal 'file-error (list result))) (with-current-buffer (if (bufferp buffer) buffer (current-buffer)) (if (zerop result) - (tramp-message v 6 "%d" result) - (tramp-message v 6 "%d\n%s" result (buffer-string))))) + (tramp-message vec 6 "%d" result) + (tramp-message vec 6 "%d\n%s" result (buffer-string))))) (error (setq result 1) - (tramp-message v 6 "%d\n%s" result (error-message-string err)))) + (tramp-message vec 6 "%d\n%s" result (error-message-string err)))) result)) ;;;###tramp-autoload @@ -4411,8 +4408,11 @@ 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) @@ -4424,6 +4424,8 @@ Invokes `password-read' if available, `read-passwd' else." (unwind-protect (with-parsed-tramp-file-name key nil + (setq user + (or user (tramp-get-connection-property key "login-as" nil))) (prog1 (or ;; See if auth-sources contains something useful. @@ -4434,24 +4436,16 @@ Invokes `password-read' if available, `read-passwd' else." (setq auth-info (auth-source-search :max 1 - (and tramp-current-user :user) - (if tramp-current-domain - (format - "%s%s%s" - tramp-current-user tramp-prefix-domain-format - tramp-current-domain) - tramp-current-user) + (and user :user) + (if domain + (concat user tramp-prefix-domain-format domain) + user) :host - (if tramp-current-port - (format - "%s%s%s" - tramp-current-host tramp-prefix-port-format - tramp-current-port) - tramp-current-host) - :port tramp-current-method - :require - (cons - :secret (and tramp-current-user '(:user)))) + (if port + (concat host tramp-prefix-port-format port) + host) + :port method + :require (cons :secret (and user '(:user)))) auth-passwd (plist-get (nth 0 auth-info) :secret) auth-passwd (if (functionp auth-passwd) @@ -4471,11 +4465,7 @@ Invokes `password-read' if available, `read-passwd' else." (defun tramp-clear-passwd (vec) "Clear password cache for connection related to VEC." (let ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (domain (tramp-file-name-domain vec)) (user-domain (tramp-file-name-user-domain vec)) - (host (tramp-file-name-host vec)) - (port (tramp-file-name-port vec)) (host-port (tramp-file-name-host-port vec)) (hop (tramp-file-name-hop vec))) (when hop @@ -4490,8 +4480,7 @@ Invokes `password-read' if available, `read-passwd' else." (auth-source-forget `(:max 1 ,(and user-domain :user) ,user-domain :host ,host-port :port ,method)) - (password-cache-remove - (tramp-make-tramp-file-name method user domain host port "")))) + (password-cache-remove (tramp-make-tramp-file-name vec 'noloc 'nohop)))) ;; Snarfed code from time-date.el. @@ -4568,7 +4557,7 @@ Only works for Bourne-like shells." ;; 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) + (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. diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 1a7727820ef..46af51ebfdb 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -7,7 +7,7 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.3.3.26.1 +;; Version: 2.4.0-pre ;; This file is part of GNU Emacs. @@ -33,7 +33,7 @@ ;; should be changed only there. ;;;###tramp-autoload -(defconst tramp-version "2.3.3.26.1" +(defconst tramp-version "2.4.0-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -55,10 +55,9 @@ ;; Check for Emacs version. (let ((x (if (>= emacs-major-version 24) "ok" - (format "Tramp 2.3.3.26.1 is not fit for %s" - (when (string-match "^.*$" (emacs-version)) - (match-string 0 (emacs-version))))))) - (unless (string-match "\\`ok\\'" x) (error "%s" x))) + (format "Tramp 2.4.0-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. (add-to-list |