summaryrefslogtreecommitdiff
path: root/lisp/net
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/net')
-rw-r--r--lisp/net/ange-ftp.el44
-rw-r--r--lisp/net/browse-url.el3
-rw-r--r--lisp/net/imap.el170
-rw-r--r--lisp/net/mailcap.el8
-rw-r--r--lisp/net/newst-backend.el297
-rw-r--r--lisp/net/pop3.el26
-rw-r--r--lisp/net/quickurl.el2
-rw-r--r--lisp/net/rcirc.el3
-rw-r--r--lisp/net/rfc2104.el10
-rw-r--r--lisp/net/shr-color.el11
-rw-r--r--lisp/net/sieve-manage.el38
-rw-r--r--lisp/net/tramp-adb.el136
-rw-r--r--lisp/net/tramp-archive.el638
-rw-r--r--lisp/net/tramp-cache.el54
-rw-r--r--lisp/net/tramp-cmds.el23
-rw-r--r--lisp/net/tramp-compat.el17
-rw-r--r--lisp/net/tramp-gvfs.el589
-rw-r--r--lisp/net/tramp-sh.el274
-rw-r--r--lisp/net/tramp-smb.el247
-rw-r--r--lisp/net/tramp.el414
-rw-r--r--lisp/net/trampver.el11
-rw-r--r--lisp/net/zeroconf.el2
22 files changed, 2026 insertions, 991 deletions
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el
index 9b23b8a4d89..c3650afa9a7 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)
@@ -3373,6 +3373,13 @@ system TYPE.")
(file-error nil))
(ange-ftp-real-file-symlink-p file)))
+(defun ange-ftp-file-regular-p (file)
+ ;; Reuse Tramp's implementation.
+ (if (ange-ftp-ftp-name file)
+ (and (file-exists-p file)
+ (eq ?- (aref (file-attribute-modes (file-attributes file)) 0)))
+ (ange-ftp-real-file-regular-p file)))
+
(defun ange-ftp-file-exists-p (name)
(setq name (expand-file-name name))
(if (ange-ftp-ftp-name name)
@@ -3404,6 +3411,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 +3452,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 +3840,7 @@ so return the size on the remote host exactly. See RFC 3659."
(ange-ftp-call-cont cont result line)))
(defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists
- keep-date preserve-uid-gid
+ keep-date _preserve-uid-gid
_preserve-selinux-context)
(interactive "fCopy file: \nFCopy %s to file: \np")
(ange-ftp-copy-file-internal filename
@@ -4385,10 +4396,13 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
(put 'directory-files-and-attributes 'ange-ftp
'ange-ftp-directory-files-and-attributes)
(put 'file-directory-p 'ange-ftp 'ange-ftp-file-directory-p)
+(put 'file-accessible-directory-p 'ange-ftp
+ 'ange-ftp-file-accessible-directory-p)
(put 'file-writable-p 'ange-ftp 'ange-ftp-file-writable-p)
(put 'file-readable-p 'ange-ftp 'ange-ftp-file-readable-p)
(put 'file-executable-p 'ange-ftp 'ange-ftp-file-executable-p)
(put 'file-symlink-p 'ange-ftp 'ange-ftp-file-symlink-p)
+(put 'file-regular-p 'ange-ftp 'ange-ftp-file-regular-p)
(put 'delete-file 'ange-ftp 'ange-ftp-delete-file)
(put 'verify-visited-file-modtime 'ange-ftp
'ange-ftp-verify-visited-file-modtime)
@@ -4469,6 +4483,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
(ange-ftp-run-real-handler 'directory-files-and-attributes args))
(defun ange-ftp-real-file-directory-p (&rest args)
(ange-ftp-run-real-handler 'file-directory-p args))
+(defun ange-ftp-real-file-accessible-directory-p (&rest args)
+ (ange-ftp-run-real-handler 'file-accessible-directory-p args))
(defun ange-ftp-real-file-writable-p (&rest args)
(ange-ftp-run-real-handler 'file-writable-p args))
(defun ange-ftp-real-file-readable-p (&rest args)
@@ -4477,6 +4493,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
(ange-ftp-run-real-handler 'file-executable-p args))
(defun ange-ftp-real-file-symlink-p (&rest args)
(ange-ftp-run-real-handler 'file-symlink-p args))
+(defun ange-ftp-real-file-regular-p (&rest args)
+ (ange-ftp-run-real-handler 'file-regular-p args))
(defun ange-ftp-real-delete-file (&rest args)
(ange-ftp-run-real-handler 'delete-file args))
(defun ange-ftp-real-verify-visited-file-modtime (&rest args)
@@ -5199,7 +5217,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..2a2ce8b9c97 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 "ext:digest-md5")
+(declare-function digest-md5-digest-response "ext:digest-md5")
+(declare-function digest-md5-digest-uri "ext:digest-md5")
+(declare-function digest-md5-challenge "ext:digest-md5")
;; User variables.
@@ -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 f0694b79ea0..4ec00450f4e 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/quickurl.el b/lisp/net/quickurl.el
index abfca383e09..a5ba26bcdc5 100644
--- a/lisp/net/quickurl.el
+++ b/lisp/net/quickurl.el
@@ -155,7 +155,7 @@ could be used here."
(defconst quickurl-reread-hook-postfix
"
;; Local Variables:
-;; eval: (progn (require 'quickurl) (add-hook 'local-write-file-hooks (lambda () (quickurl-read) nil)))
+;; eval: (progn (require 'quickurl) (add-hook 'write-file-functions (lambda () (quickurl-read) nil) nil t))
;; End:
"
"Example `quickurl-postfix' text that adds a local variable to the
diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el
index 5acbec7dcb4..abd969216f3 100644
--- a/lisp/net/rcirc.el
+++ b/lisp/net/rcirc.el
@@ -182,6 +182,8 @@ underneath each nick."
:type '(repeat string)
:group 'rcirc)
+(defvar rcirc-prompt-start-marker nil)
+
(define-minor-mode rcirc-omit-mode
"Toggle the hiding of \"uninteresting\" lines.
With a prefix argument ARG, enable Rcirc-Omit mode if ARG is
@@ -401,7 +403,6 @@ will be killed."
(defvar rcirc-nick nil)
-(defvar rcirc-prompt-start-marker nil)
(defvar rcirc-prompt-end-marker nil)
(defvar rcirc-nick-table nil)
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 ca7d1ce55a4..6303141c898 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"
@@ -210,8 +210,8 @@ This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"."
(defun shr-color-hue-to-rgb (x y h)
"Convert X Y H to RGB value."
- (when (< h 0) (incf h))
- (when (> h 1) (decf h))
+ (when (< h 0) (cl-incf h))
+ (when (> h 1) (cl-decf h))
(cond ((< h (/ 6.0)) (+ x (* (- y x) h 6)))
((< h 0.5) y)
((< h (/ 2.0 3.0)) (+ x (* (- y x) (- (/ 2.0 3.0) h) 6)))
@@ -259,8 +259,7 @@ Like rgb() or hsl()."
(let ((h (/ (string-to-number (match-string-no-properties 1 color)) 360.0))
(s (/ (string-to-number (match-string-no-properties 2 color)) 100.0))
(l (/ (string-to-number (match-string-no-properties 3 color)) 100.0)))
- (destructuring-bind (r g b)
- (shr-color-hsl-to-rgb-fractions h s l)
+ (pcase-let ((`(,r ,g ,b) (shr-color-hsl-to-rgb-fractions h s l)))
(color-rgb-to-hex r g b 2))))
;; Color names
((cdr (assoc-string color shr-color-html-colors-alist t)))
diff --git a/lisp/net/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..7a0ea71aee9 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -71,7 +71,7 @@ It is used for TCP/IP devices."
(defconst tramp-adb-ls-toolbox-regexp
(concat
- "^[[:space:]]*\\([-[:alpha:]]+\\)" ; \1 permissions
+ "^[[:space:]]*\\([-.[:alpha:]]+\\)" ; \1 permissions
"\\(?:[[:space:]]+[[:digit:]]+\\)?" ; links (Android 7/toybox)
"[[:space:]]*\\([^[:space:]]+\\)" ; \2 username
"[[:space:]]+\\([^[:space:]]+\\)" ; \3 group
@@ -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)
@@ -466,13 +458,19 @@ pass to the OPERATION."
result)))))))))
(defun tramp-adb-get-ls-command (vec)
- "Determine `ls' command at its arguments."
+ "Determine `ls' command and its arguments."
(with-tramp-connection-property vec "ls"
(tramp-message vec 5 "Finding a suitable `ls' command")
(cond
+ ;; Support Android derived systems where "ls" command is provided
+ ;; by GNU Coreutils. Force "ls" to print one column and set
+ ;; time-style to imitate other "ls" flavors.
+ ((tramp-adb-send-command-and-check
+ vec "ls --time-style=long-iso /dev/null")
+ "ls -1 --time-style=long-iso")
;; Can't disable coloring explicitly for toybox ls command. We
- ;; must force "ls" to print just one column.
- ((tramp-adb-send-command-and-check vec "toybox") "env COLUMNS=1 ls")
+ ;; also must force "ls" to print just one column.
+ ((tramp-adb-send-command-and-check vec "toybox") "ls -1")
;; On CyanogenMod based system BusyBox is used and "ls" output
;; coloring is enabled by default. So we try to disable it when
;; possible.
@@ -549,8 +547,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 +558,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 +573,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 +667,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 +687,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 +751,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 +786,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 +831,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 +869,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 +902,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 +946,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 +1052,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 +1105,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 +1115,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 +1260,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 +1289,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 +1328,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..0b5a351deaa
--- /dev/null
+++ b/lisp/net/tramp-archive.el
@@ -0,0 +1,638 @@
+;;; 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
+;; * ".msu", ".MSU" - Microsoft Windows Update packages
+;; * ".mtree" - BSD mtree format
+;; * ".odb" ".odf" ".odg" ".odp" ".ods" ".odt" - OpenDocument formats
+;; * ".pax" - Posix archives
+;; * ".rar" - RAR archives
+;; * ".rpm" - Red Hat packages
+;; * ".shar" - Shell archives
+;; * ".tar", ".tbz", ".tgz", ".tlz", ".txz" - (Compressed) tape archives
+;; * ".warc" - Web archives
+;; * ".xar" - macOS XAR archives
+;; * ".xpi" - XPInstall Mozilla addons
+;; * ".xps" - Open XML Paper Specification (OpenXPS) documents
+;; * ".zip", ".ZIP" - ZIP archives
+
+;; File archives could also be compressed, identified by an additional
+;; compression suffix. Valid compression suffixes are listed in the
+;; constant `tramp-archive-compression-suffixes'. They are ".bz2",
+;; ".gz", ".lrz", ".lz", ".lz4", ".lzma", ".lzo", ".uu", ".xz" 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", "msu" and "zip" are included with lower and upper
+ ;; letters, because Microsoft Windows provides them often with
+ ;; capital letters.
+ '("7z" ;; 7-Zip archives.
+ "apk" ;; Android package kits. Not in libarchive testsuite.
+ "ar" ;; UNIX archiver formats.
+ "cab" "CAB" ;; Microsoft Windows cabinets.
+ "cpio" ;; CPIO archives.
+ "deb" ;; Debian packages. Not in libarchive testsuite.
+ "depot" ;; HP-UX SD depot. Not in libarchive testsuite.
+ "exe" ;; Self extracting Microsoft Windows EXE files.
+ "iso" ;; ISO 9660 images.
+ "jar" ;; Java archives. Not in libarchive testsuite.
+ "lzh" "LZH" ;; Microsoft Windows compressed LHA archives.
+ "msu" "MSU" ;; Microsoft Windows Update packages. Not in testsuite.
+ "mtree" ;; BSD mtree format.
+ "odb" "odf" "odg" "odp" "ods" "odt" ;; OpenDocument formats. Not in testsuite.
+ "pax" ;; Posix archives.
+ "rar" ;; RAR archives.
+ "rpm" ;; Red Hat packages.
+ "shar" ;; Shell archives. Not in libarchive testsuite.
+ "tar" "tbz" "tgz" "tlz" "txz" ;; (Compressed) tape archives.
+ "warc" ;; Web archives.
+ "xar" ;; macOS XAR archives. Not in libarchive testsuite.
+ "xpi" ;; XPInstall Mozilla addons. Not in libarchive testsuite.
+ "xps" ;; Open XML Paper Specification (OpenXPS) documents.
+ "zip" "ZIP") ;; ZIP archives.
+ "List of suffixes which indicate a file archive.
+It must be supported by libarchive(3).")
+
+;; <http://unix-memo.readthedocs.io/en/latest/vfs.html>
+;; read and write: tar, cpio, pax , gzip , zip, bzip2, xz, lzip, lzma, ar, mtree, iso9660, compress.
+;; read only: 7-Zip, mtree, xar, lha/lzh, rar, microsoft cab.
+
+;;;###autoload
+(defconst tramp-archive-compression-suffixes
+ '("bz2" "gz" "lrz" "lz" "lz4" "lzma" "lzo" "uu" "xz" "Z")
+ "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
+hexified archive name as host, and the localname. The archive
+name is kept in slot `hop'"
+ (save-match-data
+ (unless (tramp-archive-file-name-p name)
+ (tramp-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..eb3dddcd6c5 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
@@ -1083,9 +1286,10 @@ If FILE-SYSTEM is non-nil, return file system attributes."
"Like `file-notify-add-watch' for Tramp files."
(setq file-name (expand-file-name file-name))
(with-parsed-tramp-file-name file-name nil
- ;; We cannot watch directories, because `gvfs-monitor-dir' is not
- ;; supported for gvfs-mounted directories.
- (when (file-directory-p file-name)
+ ;; TODO: We cannot watch directories, because `gio monitor' is not
+ ;; supported for gvfs-mounted directories. However,
+ ;; `file-notify-add-watch' uses directories.
+ (when (or (not (tramp-gvfs-gio-tool-p v)) (file-directory-p file-name))
(tramp-error
v 'file-notify-error "Monitoring not supported for `%s'" file-name))
(let* ((default-directory (file-name-directory file-name))
@@ -1100,67 +1304,78 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(p (apply
'start-process
"gvfs-monitor" (generate-new-buffer " *gvfs-monitor*")
- (if (tramp-gvfs-gio-tool-p v)
- `("gio" "monitor" ,(tramp-gvfs-url-file-name file-name)))
- `("gvfs-monitor-file" (tramp-gvfs-url-file-name file-name)))))
+ `("gio" "monitor" ,(tramp-gvfs-url-file-name file-name)))))
(if (not (processp p))
(tramp-error
v 'file-notify-error "Monitoring not supported for `%s'" file-name)
(tramp-message
v 6 "Run `%s', %S" (mapconcat 'identity (process-command p) " ") p)
- (tramp-set-connection-property p "vector" v)
+ (process-put p 'vector v)
(process-put p 'events events)
(process-put p 'watch-name localname)
(process-put p 'adjust-window-size-function 'ignore)
(set-process-query-on-exit-flag p nil)
- (set-process-filter p 'tramp-gvfs-monitor-file-process-filter)
+ (set-process-filter p 'tramp-gvfs-monitor-process-filter)
;; There might be an error if the monitor is not supported.
;; Give the filter a chance to read the output.
(tramp-accept-process-output p 1)
(unless (process-live-p p)
(tramp-error
- v 'file-notify-error "Monitoring not supported for `%s'" file-name))
+ p 'file-notify-error "Monitoring not supported for `%s'" file-name))
p))))
-(defun tramp-gvfs-monitor-file-process-filter (proc string)
+(defun tramp-gvfs-monitor-process-filter (proc string)
"Read output from \"gvfs-monitor-file\" and add corresponding \
file-notify events."
- (let* ((rest-string (process-get proc 'rest-string))
+ (let* ((events (process-get proc 'events))
+ (rest-string (process-get proc 'rest-string))
(dd (with-current-buffer (process-buffer proc) default-directory))
(ddu (regexp-quote (tramp-gvfs-url-file-name dd))))
(when rest-string
(tramp-message proc 10 "Previous string:\n%s" rest-string))
(tramp-message proc 6 "%S\n%s" proc string)
(setq string (concat rest-string string)
- ;; Attribute change is returned in unused wording.
- string (replace-regexp-in-string
- "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string))
- (when (string-match "Monitoring not supported" string)
+ ;; Fix action names.
+ string (replace-regexp-in-string
+ "attributes changed" "attribute-changed" string)
+ string (replace-regexp-in-string
+ "changes done" "changes-done-hint" string)
+ string (replace-regexp-in-string
+ "renamed to" "moved" string))
+ ;; https://bugs.launchpad.net/bugs/1742946
+ (when (string-match "Monitoring not supported\\|No locations given" string)
(delete-process proc))
(while (string-match
- (concat "^[\n\r]*"
- "File Monitor Event:[\n\r]+"
- "File = \\([^\n\r]+\\)[\n\r]+"
- "Event = \\([^[:blank:]]+\\)[\n\r]+")
+ (concat "^.+:"
+ "[[:space:]]\\(.+\\):"
+ "[[:space:]]" (regexp-opt tramp-gio-events t)
+ "\\([[:space:]]\\(.+\\)\\)?$")
string)
+
(let ((file (match-string 1 string))
- (action (intern-soft
- (replace-regexp-in-string
- "_" "-" (downcase (match-string 2 string))))))
+ (file1 (match-string 4 string))
+ (action (intern-soft (match-string 2 string))))
(setq string (replace-match "" nil nil string))
;; File names are returned as URL paths. We must convert them.
(when (string-match ddu file)
(setq file (replace-match dd nil nil file)))
(while (string-match "%\\([0-9A-F]\\{2\\}\\)" file)
- (setq file
- (replace-match
- (char-to-string (string-to-number (match-string 1 file) 16))
- nil nil file)))
+ (setq file (url-unhex-string file)))
+ (when (string-match ddu (or file1 ""))
+ (setq file1 (replace-match dd nil nil file1)))
+ (while (string-match "%\\([0-9A-F]\\{2\\}\\)" (or file1 ""))
+ (setq file1 (url-unhex-string file1)))
+ ;; Remove watch when file or directory to be watched is deleted.
+ (when (and (member action '(moved deleted))
+ (string-equal file (process-get proc 'watch-name)))
+ (delete-process proc))
;; Usually, we would add an Emacs event now. Unfortunately,
;; `unread-command-events' does not accept several events at
;; once. Therefore, we apply the callback directly.
- (tramp-compat-funcall 'file-notify-callback (list proc action file))))
+ (when (member action events)
+ (tramp-compat-funcall
+ 'file-notify-callback (list proc action file file1)))))
;; Save rest of the string.
(when (zerop (length string)) (setq string nil))
@@ -1178,7 +1393,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 +1418,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 +1475,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 +1485,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)))
@@ -1279,7 +1495,7 @@ file-notify events."
(defun tramp-gvfs-url-file-name (filename)
"Return FILENAME in URL syntax."
- ;; "/" must NOT be hexlified.
+ ;; "/" must NOT be hexified.
(setq filename (tramp-compat-file-name-unquote filename))
(let ((url-unreserved-chars (cons ?/ url-unreserved-chars))
result)
@@ -1290,6 +1506,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 +1534,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 +1565,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 +1604,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 +1645,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 +1661,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 +1732,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 +1748,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 +1819,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 +1831,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 +1842,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 +1859,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 +1914,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 +1945,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 +1991,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 +2082,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,8 +2361,10 @@ They are retrieved from the hal daemon."
;;; TODO:
+;; * (Customizable) unmount when exiting Emacs. See tramp-archive.el.
+
;; * Host name completion for existing mount points (afp-server,
-;; smb-server) or via smb-network.
+;; smb-server, google-drive, owncloud) or via smb-network.
;;
;; * Check, how two shares of the same SMB server can be mounted in
;; parallel.
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 9b74da65805..f619ac30633 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -962,15 +962,16 @@ busybox awk '{}' </dev/null"
(defconst tramp-vc-registered-read-file-names
"echo \"(\"
while read file; do
+ quoted=`echo \"$file\" | sed -e \"s/\\\"/\\\\\\\\\\\\\\\\\\\"/\"`
if %s \"$file\"; then
- echo \"(\\\"$file\\\" \\\"file-exists-p\\\" t)\"
+ echo \"(\\\"$quoted\\\" \\\"file-exists-p\\\" t)\"
else
- echo \"(\\\"$file\\\" \\\"file-exists-p\\\" nil)\"
+ echo \"(\\\"$quoted\\\" \\\"file-exists-p\\\" nil)\"
fi
if %s \"$file\"; then
- echo \"(\\\"$file\\\" \\\"file-readable-p\\\" t)\"
+ echo \"(\\\"$quoted\\\" \\\"file-readable-p\\\" t)\"
else
- echo \"(\\\"$file\\\" \\\"file-readable-p\\\" nil)\"
+ echo \"(\\\"$quoted\\\" \\\"file-readable-p\\\" nil)\"
fi
done
echo \")\""
@@ -1104,8 +1105,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 +1501,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 +1513,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 +1606,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 +1646,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 +1940,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 +2007,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)
@@ -2055,6 +2055,7 @@ file names."
(t2 (tramp-tramp-file-p newname))
(length (tramp-compat-file-attribute-size
(file-attributes (file-truename filename))))
+ ;; `file-extended-attributes' exists since Emacs 24.4.
(attributes (and preserve-extended-attributes
(apply 'file-extended-attributes (list filename)))))
@@ -2133,14 +2134,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 +2365,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 +2475,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 +2509,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 +2520,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 +2552,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 +2564,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 +2577,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 +2591,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 +2824,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 +2862,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 +2898,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 +2964,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 +3087,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 +3391,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 +3412,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 +3565,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 +3583,30 @@ Fall back to normal file name handler if no Tramp handler exists."
(mapcar
(lambda (x) (intern-soft (replace-regexp-in-string "_" "-" x)))
(split-string events "," 'omit))))
+ ;; "gio monitor".
+ ((setq command (tramp-get-remote-gio-monitor v))
+ (setq filter 'tramp-sh-gio-monitor-process-filter
+ events
+ (cond
+ ((and (memq 'change flags) (memq 'attribute-change flags))
+ '(created changed changes-done-hint moved deleted
+ attribute-changed))
+ ((memq 'change flags)
+ '(created changed changes-done-hint moved deleted))
+ ((memq 'attribute-change flags) '(attribute-changed)))
+ sequence `(,command "monitor" ,localname)))
+ ;; "gvfs-monitor-dir".
+ ((setq command (tramp-get-remote-gvfs-monitor-dir v))
+ (setq filter 'tramp-sh-gvfs-monitor-dir-process-filter
+ events
+ (cond
+ ((and (memq 'change flags) (memq 'attribute-change flags))
+ '(created changed changes-done-hint moved deleted
+ attribute-changed))
+ ((memq 'change flags)
+ '(created changed changes-done-hint moved deleted))
+ ((memq 'attribute-change flags) '(attribute-changed)))
+ sequence `(,command ,localname)))
;; None.
(t (tramp-error
v 'file-notify-error
@@ -3621,7 +3626,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,9 +3637,67 @@ 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-gio-monitor-process-filter (proc string)
+ "Read output from \"gio monitor\" and add corresponding file-notify events."
+ (let ((events (process-get proc 'events))
+ (remote-prefix
+ (with-current-buffer (process-buffer proc)
+ (file-remote-p default-directory)))
+ (rest-string (process-get proc 'rest-string)))
+ (when rest-string
+ (tramp-message proc 10 "Previous string:\n%s" rest-string))
+ (tramp-message proc 6 "%S\n%s" proc string)
+ (setq string (concat rest-string string)
+ ;; Fix action names.
+ string (replace-regexp-in-string
+ "attributes changed" "attribute-changed" string)
+ string (replace-regexp-in-string
+ "changes done" "changes-done-hint" string)
+ string (replace-regexp-in-string
+ "renamed to" "moved" string))
+ ;; https://bugs.launchpad.net/bugs/1742946
+ (when (string-match "Monitoring not supported\\|No locations given" string)
+ (delete-process proc))
+
+ (while (string-match
+ (concat "^[^:]+:"
+ "[[:space:]]\\([^:]+\\):"
+ "[[:space:]]" (regexp-opt tramp-gio-events t)
+ "\\([[:space:]]\\([^:]+\\)\\)?$")
+ string)
+
+ (let* ((file (match-string 1 string))
+ (file1 (match-string 4 string))
+ (object
+ (list
+ proc
+ (list
+ (intern-soft (match-string 2 string)))
+ ;; File names are returned as absolute paths. We must
+ ;; add the remote prefix.
+ (concat remote-prefix file)
+ (when file1 (concat remote-prefix file1)))))
+ (setq string (replace-match "" nil nil string))
+ ;; Remove watch when file or directory to be watched is deleted.
+ (when (and (member (cl-caadr object) '(moved deleted))
+ (string-equal file (process-get proc 'watch-name)))
+ (delete-process proc))
+ ;; Usually, we would add an Emacs event now. Unfortunately,
+ ;; `unread-command-events' does not accept several events at
+ ;; once. Therefore, we apply the handler directly.
+ (when (member (cl-caadr object) events)
+ (tramp-compat-funcall
+ 'file-notify-handle-event
+ `(file-notify ,object file-notify-callback)))))
+
+ ;; Save rest of the string.
+ (when (zerop (length string)) (setq string nil))
+ (when string (tramp-message proc 10 "Rest string:\n%s" string))
+ (process-put proc 'rest-string string)))
+
(defun tramp-sh-gvfs-monitor-dir-process-filter (proc string)
"Read output from \"gvfs-monitor-dir\" and add corresponding \
file-notify events."
@@ -3650,8 +3713,6 @@ file-notify events."
;; Attribute change is returned in unused wording.
string (replace-regexp-in-string
"ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string))
- (when (string-match "Monitoring not supported" string)
- (delete-process proc))
(while (string-match
(concat "^[\n\r]*"
@@ -3697,12 +3758,11 @@ file-notify events."
(tramp-message proc 6 "%S\n%s" proc string)
(dolist (line (split-string string "[\n\r]+" 'omit))
;; Check, whether there is a problem.
- (unless
- (string-match
- (concat "^[^[:blank:]]+"
- "[[:blank:]]+\\([^[:blank:]]+\\)+"
- "\\([[:blank:]]+\\([^\n\r]+\\)\\)?")
- line)
+ (unless (string-match
+ (concat "^[^[:blank:]]+"
+ "[[:blank:]]+\\([^[:blank:]]+\\)+"
+ "\\([[:blank:]]+\\([^\n\r]+\\)\\)?")
+ line)
(tramp-error proc 'file-notify-error "%s" line))
(let ((object
@@ -4036,7 +4096,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 +4184,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 +4530,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 +4788,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 +4812,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 +4871,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 +5305,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)))))
@@ -5471,6 +5525,12 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil."
vec (format "%s --block-size=1 --output=size,used,avail /" result))
result))))
+(defun tramp-get-remote-gio-monitor (vec)
+ "Determine remote `gio-monitor' command."
+ (with-tramp-connection-property vec "gio-monitor"
+ (tramp-message vec 5 "Finding a suitable `gio-monitor' command")
+ (tramp-find-executable vec "gio" (tramp-get-remote-path vec) t t)))
+
(defun tramp-get-remote-gvfs-monitor-dir (vec)
"Determine remote `gvfs-monitor-dir' command."
(with-tramp-connection-property vec "gvfs-monitor-dir"
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..fe9f1976944 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 (and (stringp localname) (string-equal "~" localname))
+ (concat filename "/")
+ filename))))
(defun tramp-handle-set-visited-file-modtime (&optional time-list)
"Like `set-visited-file-modtime' for Tramp files."
@@ -3574,34 +3600,39 @@ 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)))))))))
+
+;; This is used in tramp-gvfs.el and tramp-sh.el.
+(defconst tramp-gio-events
+ '("attribute-changed" "changed" "changes-done-hint"
+ "created" "deleted" "moved" "pre-unmount" "unmounted")
+ "List of events \"gio monitor\" could send.")
+
+;; This is the default handler. tramp-gvfs.el and tramp-sh.el have
+;; their own one.
(defun tramp-handle-file-notify-add-watch (filename _flags _callback)
"Like `file-notify-add-watch' for Tramp files."
- ;; This is the default handler. tramp-gvfs.el and tramp-sh.el have
- ;; their own one.
(setq filename (expand-file-name filename))
(with-parsed-tramp-file-name filename nil
(tramp-error
@@ -3633,17 +3664,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 +3797,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 +3851,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 +4170,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 +4227,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 +4237,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 +4352,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 +4373,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 +4384,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 +4400,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 +4414,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 +4430,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 +4442,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)
@@ -4459,6 +4459,7 @@ Invokes `password-read' if available, `read-passwd' else."
auth-passwd))))
;; Try the password cache.
(let ((password (password-read pw-prompt key)))
+ ;; FIXME test password works before caching it.
(password-cache-add key password)
password)
;; Else, get the password interactively.
@@ -4471,11 +4472,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 +4487,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 +4564,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
diff --git a/lisp/net/zeroconf.el b/lisp/net/zeroconf.el
index 351fc9fc305..0a3f2777b9a 100644
--- a/lisp/net/zeroconf.el
+++ b/lisp/net/zeroconf.el
@@ -382,6 +382,8 @@ TYPE. The resulting list has the format
;; `zeroconf-services-hash'.
(gethash (concat name "/" type) zeroconf-services-hash nil))
+(defvar dbus-debug)
+
(defun zeroconf-resolve-service (service)
"Return all service attributes SERVICE as list.
NAME must be a string. The service must be of service type
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-28 14:35:39 +0000