summaryrefslogtreecommitdiff
path: root/lisp/net
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/net')
-rw-r--r--lisp/net/newst-backend.el297
-rw-r--r--lisp/net/pinentry.el460
-rw-r--r--lisp/net/tramp-adb.el103
-rw-r--r--lisp/net/tramp-archive.el564
-rw-r--r--lisp/net/tramp-cache.el51
-rw-r--r--lisp/net/tramp-cmds.el22
-rw-r--r--lisp/net/tramp-compat.el16
-rw-r--r--lisp/net/tramp-gvfs.el101
-rw-r--r--lisp/net/tramp-sh.el117
-rw-r--r--lisp/net/tramp-smb.el227
-rw-r--r--lisp/net/tramp.el341
-rw-r--r--lisp/net/trampver.el6
12 files changed, 1190 insertions, 1115 deletions
diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el
index ed60a8a3aea..00e81f8b5e2 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-2017 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/pinentry.el b/lisp/net/pinentry.el
deleted file mode 100644
index f8d81fde912..00000000000
--- a/lisp/net/pinentry.el
+++ /dev/null
@@ -1,460 +0,0 @@
-;;; pinentry.el --- GnuPG Pinentry server implementation -*- lexical-binding: t -*-
-
-;; Copyright (C) 2015-2017 Free Software Foundation, Inc.
-
-;; Author: Daiki Ueno <ueno@gnu.org>
-;; Version: 0.1
-;; Keywords: GnuPG
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This package allows GnuPG passphrase to be prompted through the
-;; minibuffer instead of graphical dialog.
-;;
-;; To use, add "allow-emacs-pinentry" to "~/.gnupg/gpg-agent.conf",
-;; reload the configuration with "gpgconf --reload gpg-agent", and
-;; start the server with M-x pinentry-start.
-;;
-;; The actual communication path between the relevant components is
-;; as follows:
-;;
-;; gpg --> gpg-agent --> pinentry --> Emacs
-;;
-;; where pinentry and Emacs communicate through a Unix domain socket
-;; created at:
-;;
-;; ${TMPDIR-/tmp}/emacs$(id -u)/pinentry
-;;
-;; under the same directory which server.el uses. The protocol is a
-;; subset of the Pinentry Assuan protocol described in (info
-;; "(pinentry) Protocol").
-;;
-;; NOTE: As of August 2015, this feature requires newer versions of
-;; GnuPG (2.1.5+) and Pinentry (0.9.5+).
-
-;;; Code:
-
-(eval-when-compile (require 'cl-lib))
-
-(defgroup pinentry nil
- "The Pinentry server"
- :version "25.1"
- :group 'external)
-
-(defcustom pinentry-popup-prompt-window t
- "If non-nil, display multiline prompt in another window."
- :type 'boolean
- :group 'pinentry)
-
-(defcustom pinentry-prompt-window-height 5
- "Number of lines used to display multiline prompt."
- :type 'integer
- :group 'pinentry)
-
-(defvar pinentry-debug nil)
-(defvar pinentry-debug-buffer nil)
-(defvar pinentry--server-process nil)
-(defvar pinentry--connection-process-list nil)
-
-(defvar pinentry--labels nil)
-(put 'pinentry-read-point 'permanent-local t)
-(defvar pinentry--read-point nil)
-(put 'pinentry--read-point 'permanent-local t)
-
-(defvar pinentry--prompt-buffer nil)
-
-;; We use the same location as `server-socket-dir', when local sockets
-;; are supported.
-(defvar pinentry--socket-dir
- (format "%s/emacs%d" (or (getenv "TMPDIR") "/tmp") (user-uid))
- "The directory in which to place the server socket.
-If local sockets are not supported, this is nil.")
-
-(defconst pinentry--set-label-commands
- '("SETPROMPT" "SETTITLE" "SETDESC"
- "SETREPEAT" "SETREPEATERROR"
- "SETOK" "SETCANCEL" "SETNOTOK"))
-
-;; These error codes are defined in libgpg-error/src/err-codes.h.in.
-(defmacro pinentry--error-code (code)
- (logior (lsh 5 24) code))
-(defconst pinentry--error-not-implemented
- (cons (pinentry--error-code 69) "not implemented"))
-(defconst pinentry--error-cancelled
- (cons (pinentry--error-code 99) "cancelled"))
-(defconst pinentry--error-not-confirmed
- (cons (pinentry--error-code 114) "not confirmed"))
-
-(autoload 'server-ensure-safe-dir "server")
-
-(defvar pinentry-prompt-mode-map
- (let ((keymap (make-sparse-keymap)))
- (define-key keymap "q" 'quit-window)
- keymap))
-
-(define-derived-mode pinentry-prompt-mode special-mode "Pinentry"
- "Major mode for `pinentry--prompt-buffer'."
- (buffer-disable-undo)
- (setq truncate-lines t
- buffer-read-only t))
-
-(defun pinentry--prompt (labels query-function &rest query-args)
- (let ((desc (cdr (assq 'desc labels)))
- (error (cdr (assq 'error labels)))
- (prompt (cdr (assq 'prompt labels))))
- (when (string-match "[ \n]*\\'" prompt)
- (setq prompt (concat
- (substring
- prompt 0 (match-beginning 0)) " ")))
- (when error
- (setq desc (concat "Error: " (propertize error 'face 'error)
- "\n" desc)))
- (if (and desc pinentry-popup-prompt-window)
- (save-window-excursion
- (delete-other-windows)
- (unless (and pinentry--prompt-buffer
- (buffer-live-p pinentry--prompt-buffer))
- (setq pinentry--prompt-buffer (generate-new-buffer "*Pinentry*")))
- (if (get-buffer-window pinentry--prompt-buffer)
- (delete-window (get-buffer-window pinentry--prompt-buffer)))
- (with-current-buffer pinentry--prompt-buffer
- (let ((inhibit-read-only t)
- buffer-read-only)
- (erase-buffer)
- (insert desc))
- (pinentry-prompt-mode)
- (goto-char (point-min)))
- (if (> (window-height)
- pinentry-prompt-window-height)
- (set-window-buffer (split-window nil
- (- (window-height)
- pinentry-prompt-window-height))
- pinentry--prompt-buffer)
- (pop-to-buffer pinentry--prompt-buffer)
- (if (> (window-height) pinentry-prompt-window-height)
- (shrink-window (- (window-height)
- pinentry-prompt-window-height))))
- (prog1 (apply query-function prompt query-args)
- (quit-window)))
- (apply query-function (concat desc "\n" prompt) query-args))))
-
-;;;###autoload
-(defun pinentry-start (&optional quiet)
- "Start a Pinentry service.
-
-Once the environment is properly set, subsequent invocations of
-the gpg command will interact with Emacs for passphrase input.
-
-If the optional QUIET argument is non-nil, messages at startup
-will not be shown."
- (interactive)
- (unless (featurep 'make-network-process '(:family local))
- (error "local sockets are not supported"))
- (if (process-live-p pinentry--server-process)
- (unless quiet
- (message "Pinentry service is already running"))
- (let* ((server-file (expand-file-name "pinentry" pinentry--socket-dir)))
- (server-ensure-safe-dir pinentry--socket-dir)
- ;; Delete the socket files made by previous server invocations.
- (ignore-errors
- (let (delete-by-moving-to-trash)
- (delete-file server-file)))
- (cl-letf (((default-file-modes) ?\700))
- (setq pinentry--server-process
- (make-network-process
- :name "pinentry"
- :server t
- :noquery t
- :sentinel #'pinentry--process-sentinel
- :filter #'pinentry--process-filter
- :coding 'no-conversion
- :family 'local
- :service server-file))
- (process-put pinentry--server-process :server-file server-file)))))
-
-(defun pinentry-stop ()
- "Stop a Pinentry service."
- (interactive)
- (when (process-live-p pinentry--server-process)
- (delete-process pinentry--server-process))
- (setq pinentry--server-process nil)
- (dolist (process pinentry--connection-process-list)
- (when (buffer-live-p (process-buffer process))
- (kill-buffer (process-buffer process))))
- (setq pinentry--connection-process-list nil))
-
-(defun pinentry--labels-to-shortcuts (labels)
- "Convert strings in LABEL by stripping mnemonics."
- (mapcar (lambda (label)
- (when label
- (let (c)
- (if (string-match "\\(?:\\`\\|[^_]\\)_\\([[:alnum:]]\\)" label)
- (let ((key (match-string 1 label)))
- (setq c (downcase (aref key 0)))
- (setq label (replace-match
- (propertize key 'face 'underline)
- t t label)))
- (setq c (if (= (length label) 0)
- ??
- (downcase (aref label 0)))))
- ;; Double underscores mean a single underscore.
- (when (string-match "__" label)
- (setq label (replace-match "_" t t label)))
- (cons c label))))
- labels))
-
-(defun pinentry--escape-string (string)
- "Escape STRING in the Assuan percent escape."
- (let ((length (length string))
- (index 0)
- (count 0))
- (while (< index length)
- (if (memq (aref string index) '(?\n ?\r ?%))
- (setq count (1+ count)))
- (setq index (1+ index)))
- (setq index 0)
- (let ((result (make-string (+ length (* count 2)) ?\0))
- (result-index 0)
- c)
- (while (< index length)
- (setq c (aref string index))
- (if (memq c '(?\n ?\r ?%))
- (let ((hex (format "%02X" c)))
- (aset result result-index ?%)
- (setq result-index (1+ result-index))
- (aset result result-index (aref hex 0))
- (setq result-index (1+ result-index))
- (aset result result-index (aref hex 1))
- (setq result-index (1+ result-index)))
- (aset result result-index c)
- (setq result-index (1+ result-index)))
- (setq index (1+ index)))
- result)))
-
-(defun pinentry--unescape-string (string)
- "Unescape STRING in the Assuan percent escape."
- (let ((length (length string))
- (index 0))
- (let ((result (make-string length ?\0))
- (result-index 0)
- c)
- (while (< index length)
- (setq c (aref string index))
- (if (and (eq c '?%) (< (+ index 2) length))
- (progn
- (aset result result-index
- (string-to-number (substring string
- (1+ index)
- (+ index 3))
- 16))
- (setq result-index (1+ result-index))
- (setq index (+ index 2)))
- (aset result result-index c)
- (setq result-index (1+ result-index)))
- (setq index (1+ index)))
- (substring result 0 result-index))))
-
-(defun pinentry--send-data (process escaped)
- "Send a string ESCAPED to a process PROCESS.
-ESCAPED will be split if it exceeds the line length limit of the
-Assuan protocol."
- (let ((length (length escaped))
- (index 0))
- (if (= length 0)
- (process-send-string process "D \n")
- (while (< index length)
- ;; 997 = ASSUAN_LINELENGTH (= 1000) - strlen ("D \n")
- (let* ((sub-length (min (- length index) 997))
- (sub (substring escaped index (+ index sub-length))))
- (unwind-protect
- (progn
- (process-send-string process "D ")
- (process-send-string process sub)
- (process-send-string process "\n"))
- (clear-string sub))
- (setq index (+ index sub-length)))))))
-
-(defun pinentry--send-error (process error)
- (process-send-string process (format "ERR %d %s\n" (car error) (cdr error))))
-
-(defun pinentry--process-filter (process input)
- (unless (buffer-live-p (process-buffer process))
- (let ((buffer (generate-new-buffer " *pinentry*")))
- (set-process-buffer process buffer)
- (with-current-buffer buffer
- (if (fboundp 'set-buffer-multibyte)
- (set-buffer-multibyte nil))
- (make-local-variable 'pinentry--read-point)
- (setq pinentry--read-point (point-min))
- (make-local-variable 'pinentry--labels))))
- (with-current-buffer (process-buffer process)
- (when pinentry-debug
- (with-current-buffer
- (or pinentry-debug-buffer
- (setq pinentry-debug-buffer (generate-new-buffer
- " *pinentry-debug*")))
- (goto-char (point-max))
- (insert input)))
- (save-excursion
- (goto-char (point-max))
- (insert input)
- (goto-char pinentry--read-point)
- (beginning-of-line)
- (while (looking-at ".*\n") ;the input line finished
- (if (looking-at "\\([A-Z_]+\\) ?\\(.*\\)")
- (let ((command (match-string 1))
- (string (pinentry--unescape-string (match-string 2))))
- (pcase command
- ((and set (guard (member set pinentry--set-label-commands)))
- (when (> (length string) 0)
- (let* ((symbol (intern (downcase (substring set 3))))
- (entry (assq symbol pinentry--labels))
- (label (decode-coding-string string 'utf-8)))
- (if entry
- (setcdr entry label)
- (push (cons symbol label) pinentry--labels))))
- (ignore-errors
- (process-send-string process "OK\n")))
- ("NOP"
- (ignore-errors
- (process-send-string process "OK\n")))
- ("GETPIN"
- (let ((confirm (not (null (assq 'repeat pinentry--labels))))
- passphrase escaped-passphrase encoded-passphrase)
- (unwind-protect
- (condition-case err
- (progn
- (setq passphrase
- (pinentry--prompt
- pinentry--labels
- #'read-passwd confirm))
- (setq escaped-passphrase
- (pinentry--escape-string
- passphrase))
- (setq encoded-passphrase (encode-coding-string
- escaped-passphrase
- 'utf-8))
- (ignore-errors
- (pinentry--send-data
- process encoded-passphrase)
- (process-send-string process "OK\n")))
- (error
- (message "GETPIN error %S" err)
- (ignore-errors
- (pinentry--send-error
- process
- pinentry--error-cancelled))))
- (if passphrase
- (clear-string passphrase))
- (if escaped-passphrase
- (clear-string escaped-passphrase))
- (if encoded-passphrase
- (clear-string encoded-passphrase))))
- (setq pinentry--labels nil))
- ("CONFIRM"
- (let ((prompt
- (or (cdr (assq 'prompt pinentry--labels))
- "Confirm? "))
- (buttons
- (delq nil
- (pinentry--labels-to-shortcuts
- (list (cdr (assq 'ok pinentry--labels))
- (cdr (assq 'notok pinentry--labels))
- (cdr (assq 'cancel pinentry--labels))))))
- entry)
- (if buttons
- (progn
- (setq prompt
- (concat prompt " ("
- (mapconcat #'cdr buttons
- ", ")
- ") "))
- (if (setq entry (assq 'prompt pinentry--labels))
- (setcdr entry prompt)
- (setq pinentry--labels (cons (cons 'prompt prompt)
- pinentry--labels)))
- (condition-case nil
- (let ((result (pinentry--prompt pinentry--labels
- #'read-char)))
- (if (eq result (caar buttons))
- (ignore-errors
- (process-send-string process "OK\n"))
- (if (eq result (car (nth 1 buttons)))
- (ignore-errors
- (pinentry--send-error
- process
- pinentry--error-not-confirmed))
- (ignore-errors
- (pinentry--send-error
- process
- pinentry--error-cancelled)))))
- (error
- (ignore-errors
- (pinentry--send-error
- process
- pinentry--error-cancelled)))))
- (if (setq entry (assq 'prompt pinentry--labels))
- (setcdr entry prompt)
- (setq pinentry--labels (cons (cons 'prompt prompt)
- pinentry--labels)))
- (if (condition-case nil
- (pinentry--prompt pinentry--labels #'y-or-n-p)
- (quit))
- (ignore-errors
- (process-send-string process "OK\n"))
- (ignore-errors
- (pinentry--send-error
- process
- pinentry--error-not-confirmed))))
- (setq pinentry--labels nil)))
- (_ (ignore-errors
- (pinentry--send-error
- process
- pinentry--error-not-implemented))))
- (forward-line)
- (setq pinentry--read-point (point))))))))
-
-(defun pinentry--process-sentinel (process _status)
- "The process sentinel for Emacs server connections."
- ;; If this is a new client process, set the query-on-exit flag to nil
- ;; for this process (it isn't inherited from the server process).
- (when (and (eq (process-status process) 'open)
- (process-query-on-exit-flag process))
- (push process pinentry--connection-process-list)
- (set-process-query-on-exit-flag process nil)
- (ignore-errors
- (process-send-string process "OK Your orders please\n")))
- ;; Kill the process buffer of the connection process.
- (when (and (not (process-contact process :server))
- (eq (process-status process) 'closed))
- (when (buffer-live-p (process-buffer process))
- (kill-buffer (process-buffer process)))
- (setq pinentry--connection-process-list
- (delq process pinentry--connection-process-list)))
- ;; Delete the associated connection file, if applicable.
- ;; Although there's no 100% guarantee that the file is owned by the
- ;; running Emacs instance, server-start uses server-running-p to check
- ;; for possible servers before doing anything, so it *should* be ours.
- (and (process-contact process :server)
- (eq (process-status process) 'closed)
- (ignore-errors
- (delete-file (process-get process :server-file)))))
-
-(provide 'pinentry)
-
-;;; pinentry.el ends here
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index 8399c02923d..c614acfa4db 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -114,7 +114,7 @@ It is used for TCP/IP devices."
(file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
(file-acl . ignore)
(file-attributes . tramp-adb-handle-file-attributes)
- (file-directory-p . tramp-adb-handle-file-directory-p)
+ (file-directory-p . tramp-handle-file-directory-p)
(file-equal-p . tramp-handle-file-equal-p)
;; FIXME: This is too sloppy.
(file-executable-p . tramp-handle-file-exists-p)
@@ -199,11 +199,13 @@ pass to the OPERATION."
(with-temp-buffer
;; `call-process' does not react on timer under MS Windows.
;; That's why we use `start-process'.
+ ;; We don't know yet whether we need a user or host name for the
+ ;; connection vector. We assume we don't, it will be OK in most
+ ;; of the cases. Otherwise, there might be an additional trace
+ ;; buffer, which doesn't hurt.
(let ((p (start-process
tramp-adb-program (current-buffer) tramp-adb-program "devices"))
- (v (make-tramp-file-name
- :method tramp-adb-method :user tramp-current-user
- :host tramp-current-host))
+ (v (make-tramp-file-name :method tramp-adb-method))
result)
(tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " "))
(process-put p 'adjust-window-size-function 'ignore)
@@ -245,16 +247,8 @@ pass to the OPERATION."
;; be problems with UNC shares or Cygwin mounts.
(let ((default-directory (tramp-compat-temporary-file-directory)))
(tramp-make-tramp-file-name
- method user domain host port
- (tramp-drop-volume-letter
- (tramp-run-real-handler
- 'expand-file-name (list localname))))))))
-
-(defun tramp-adb-handle-file-directory-p (filename)
- "Like `file-directory-p' for Tramp files."
- (eq (tramp-compat-file-attribute-type
- (file-attributes (file-truename filename)))
- t))
+ v (tramp-drop-volume-letter
+ (tramp-run-real-handler 'expand-file-name (list localname))))))))
(defun tramp-adb-handle-file-system-info (filename)
"Like `file-system-info' for Tramp files."
@@ -288,7 +282,7 @@ pass to the OPERATION."
"%s%s"
(with-parsed-tramp-file-name (expand-file-name filename) nil
(tramp-make-tramp-file-name
- method user domain host port
+ v
(with-tramp-file-property v localname "file-truename"
(let ((result nil)) ; result steps in reverse order
(tramp-message v 4 "Finding true name for `%s'" filename)
@@ -316,12 +310,10 @@ pass to the OPERATION."
(tramp-compat-file-attribute-type
(file-attributes
(tramp-make-tramp-file-name
- method user domain host port
- (mapconcat 'identity
- (append '("")
- (reverse result)
- (list thisstep))
- "/")))))
+ v (mapconcat 'identity
+ (append
+ '("") (reverse result) (list thisstep))
+ "/")))))
(cond ((string= "." thisstep)
(tramp-message v 5 "Ignoring step `.'"))
((string= ".." thisstep)
@@ -549,8 +541,8 @@ Emacs dired can't find files."
(let ((par (expand-file-name ".." dir)))
(unless (file-directory-p par)
(make-directory par parents))))
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-directory-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-directory-properties v localname)
(unless (or (tramp-adb-send-command-and-check
v (format "mkdir %s" (tramp-shell-quote-argument localname)))
(and parents (file-directory-p dir)))
@@ -560,11 +552,11 @@ Emacs dired can't find files."
"Like `delete-directory' for Tramp files."
(setq directory (expand-file-name directory))
(with-parsed-tramp-file-name (file-truename directory) nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-directory-property v localname))
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-directory-properties v localname))
(with-parsed-tramp-file-name directory nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-directory-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-directory-properties v localname)
(tramp-adb-barf-unless-okay
v (format "%s %s"
(if recursive "rm -r" "rmdir")
@@ -575,8 +567,8 @@ Emacs dired can't find files."
"Like `delete-file' for Tramp files."
(setq filename (expand-file-name filename))
(with-parsed-tramp-file-name filename nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
(tramp-adb-barf-unless-okay
v (format "rm %s" (tramp-shell-quote-argument localname))
"Couldn't delete %s" filename)))
@@ -669,8 +661,8 @@ But handle the case, if the \"test\" command is not available."
;; We must also flush the cache of the directory, because
;; `file-attributes' reads the values from there.
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
(let* ((curbuf (current-buffer))
(tmpfile (tramp-compat-make-temp-file filename)))
(when (and append (file-exists-p filename))
@@ -700,15 +692,15 @@ But handle the case, if the \"test\" command is not available."
(defun tramp-adb-handle-set-file-modes (filename mode)
"Like `set-file-modes' for Tramp files."
(with-parsed-tramp-file-name filename nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
(tramp-adb-send-command-and-check v (format "chmod %o %s" mode localname))))
(defun tramp-adb-handle-set-file-times (filename &optional time)
"Like `set-file-times' for Tramp files."
(with-parsed-tramp-file-name filename nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (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 +736,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 +771,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 +816,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 +854,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 +887,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 +931,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 +1037,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 +1090,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 +1100,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 +1245,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.
@@ -1324,7 +1313,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..d3b2712fb39
--- /dev/null
+++ b/lisp/net/tramp-archive.el
@@ -0,0 +1,564 @@
+;;; tramp-archive.el --- Tramp archive manager -*- lexical-binding:t -*-
+
+;; Copyright (C) 2017 Free Software Foundation, Inc.
+
+;; Author: Michael Albinus <michael.albinus@gmx.de>
+;; Keywords: comm, processes
+;; Package: tramp
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Access functions for file archives. This is possible only on
+;; machines which have installed the virtual file system for the Gnome
+;; Desktop (GVFS). Internally, file archives are mounted via the GVFS
+;; "archive" method.
+
+;; A file archive is a regular file of kind "/path/to/dir/file.EXT".
+;; The extension ".EXT" identifies the type of the file archive. A
+;; file inside a file archive, called archive file name, has the name
+;; "/path/to/dir/file.EXT/dir/file".
+
+;; Most of the magic file name operations are implemented for archive
+;; file names, exceptions are all operations which write into a file
+;; archive, and process related operations. Therefore, functions like
+
+;; (copy-file "/path/to/dir/file.tar/dir/file" "/somewhere/else")
+
+;; work out of the box. This is also true for file name completion,
+;; and for libraries like `dired' or `ediff', which accept archive
+;; file names as well.
+
+;; File archives are identified by the file name extension ".EXT".
+;; Since GVFS uses internally the library libarchive(3), all suffixes,
+;; which are accepted by this library, work also for archive file
+;; names. Accepted suffixes are listed in the constant
+;; `tramp-archive-suffixes'. They are
+
+;; * ".7z" - 7-Zip archives
+;; * ".apk" - Android package kits
+;; * ".ar" - UNIX archiver formats
+;; * ".cab", ".CAB" - Microsoft Windows cabinets
+;; * ".cpio" - CPIO archives
+;; * ".deb" - Debian packages
+;; * ".depot" - HP-UX SD depots
+;; * ".exe" - Self extracting Microsoft Windows EXE files
+;; * ".iso" - ISO 9660 images
+;; * ".jar" - Java archives
+;; * ".lzh", "LZH" - Microsoft Windows compressed LHA archives
+;; * ".mtree" - BSD mtree format
+;; * ".pax" - Posix archives
+;; * ".rar" - RAR archives
+;; * ".rpm" - Red Hat packages
+;; * ".shar" - Shell archives
+;; * ".tar", "tbz", "tgz", "tlz", "txz" - (Compressed) tape archives
+;; * ".warc" - Web archives
+;; * ".xar" - macOS XAR archives
+;; * ".xps" - Open XML Paper Specification (OpenXPS) documents
+;; * ".zip", ".ZIP" - ZIP archives
+
+;; File archives could also be compressed, identified by an additional
+;; compression suffix. Valid compression suffixes are listed in the
+;; constant `tramp-archive-compression-suffixes'. They are ".bz2",
+;; ".gz", ".lrz", ".lz", ".lz4", ".lzma", ".lzo", ".uu", ".xz" and
+;; ".Z". A valid archive file name would be
+;; "/path/to/dir/file.tar.gz/dir/file". Even several suffixes in a
+;; row are possible, like "/path/to/dir/file.tar.gz.uu/dir/file".
+
+;; An archive file name could be a remote file name, as in
+;; "/ftp:anonymous@ftp.gnu.org:/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL".
+;; Since all file operations are mapped internally to GVFS operations,
+;; remote file names supported by tramp-gvfs.el perform better,
+;; because no local copy of the file archive must be downloaded first.
+;; For example, "/sftp:user@host:..." performs better than the similar
+;; "/scp:user@host:...". See the constant
+;; `tramp-archive-all-gvfs-methods' for a complete list of
+;; tramp-gvfs.el supported method names.
+
+;; If `url-handler-mode' is enabled, archives could be visited via
+;; URLs, like "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL".
+;; This allows complex file operations like
+
+;; (ediff-directories
+;; "https://ftp.gnu.org/gnu/tramp/tramp-2.3.1.tar.gz/tramp-2.3.1"
+;; "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/tramp-2.3.2" "")
+
+;; It is even possible to access file archives in file archives, as
+
+;; (find-file
+;; "http://ftp.debian.org/debian/pool/main/c/coreutils/coreutils_8.28-1_amd64.deb/control.tar.gz/control")
+
+;;; Code:
+
+(require 'tramp-gvfs)
+
+(autoload 'dired-uncache "dired")
+(autoload 'url-tramp-convert-url-to-tramp "url-tramp")
+(defvar url-handler-mode-hook)
+(defvar url-handler-regexp)
+(defvar url-tramp-protocols)
+
+;; <https://github.com/libarchive/libarchive/wiki/LibarchiveFormats>
+;;;###tramp-autoload
+(defconst tramp-archive-suffixes
+ ;; "cab", "lzh" and "zip" are included with lower and upper letters,
+ ;; because Microsoft Windows provides them often with capital
+ ;; letters.
+ '("7z" ;; 7-Zip archives.
+ "apk" ;; Android package kits. Not in libarchive testsuite.
+ "ar" ;; UNIX archiver formats.
+ "cab" "CAB" ;; Microsoft Windows cabinets.
+ "cpio" ;; CPIO archives.
+ "deb" ;; Debian packages. Not in libarchive testsuite.
+ "depot" ;; HP-UX SD depot. Not in libarchive testsuite.
+ "exe" ;; Self extracting Microsoft Windows EXE files.
+ "iso" ;; ISO 9660 images.
+ "jar" ;; Java archives. Not in libarchive testsuite.
+ "lzh" "LZH" ;; Microsoft Windows compressed LHA archives.
+ "mtree" ;; BSD mtree format.
+ "pax" ;; Posix archives.
+ "rar" ;; RAR archives.
+ "rpm" ;; Red Hat packages.
+ "shar" ;; Shell archives. Not in libarchive testsuite.
+ "tar" "tbz" "tgz" "tlz" "txz" ;; (Compressed) tape archives.
+ "warc" ;; Web archives.
+ "xar" ;; macOS XAR archives. Not in libarchive testsuite.
+ "xps" ;; Open XML Paper Specification (OpenXPS) documents.
+ "zip" "ZIP") ;; ZIP archives.
+ "List of suffixes which indicate a file archive.
+It must be supported by libarchive(3).")
+
+;; <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,
+
+;;;###tramp-autoload
+(defconst tramp-archive-compression-suffixes
+ '("bz2" "gz" "lrz" "lz" "lz4" "lzma" "lzo" "uu" "xz" "Z")
+ "List of suffixes which indicate a compressed file.
+It must be supported by libarchive(3).")
+
+;;;###tramp-autoload
+(defconst tramp-archive-file-name-regexp
+ (concat
+ "\\`" "\\(" ".+" "\\."
+ ;; Default suffixes ...
+ (regexp-opt tramp-archive-suffixes)
+ ;; ... with compression.
+ "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*"
+ "\\)" ;; \1
+ "\\(" "/" ".*" "\\)" "\\'") ;; \2
+ "Regular expression matching archive file names.")
+
+;;;###tramp-autoload
+(defconst tramp-archive-method "archive"
+ "Method name for archives in GVFS.")
+
+(defconst tramp-archive-all-gvfs-methods
+ (cons tramp-archive-method
+ (let ((values (cdr (cadr (get 'tramp-gvfs-methods 'custom-type)))))
+ (setq values (mapcar 'last values)
+ values (mapcar 'car values))))
+ "List of all methods `tramp-gvfs-methods' offers.")
+
+
+;; New handlers should be added here.
+;;;###tramp-autoload
+(defconst tramp-archive-file-name-handler-alist
+ '((access-file . ignore)
+ (add-name-to-file . tramp-archive-handle-not-implemented)
+ ;; `byte-compiler-base-file-name' performed by default handler.
+ ;; `copy-directory' performed by default handler.
+ (copy-file . tramp-archive-handle-copy-file)
+ (delete-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 GVFS archive method.
+Operations not mentioned here will be handled by the default Emacs primitives.")
+
+;;;###tramp-autoload
+(defun tramp-archive-file-name-handler (operation &rest args)
+ "Invoke the GVFS archive related OPERATION.
+First arg specifies the OPERATION, second arg is a list of arguments to
+pass to the OPERATION."
+ (unless tramp-gvfs-enabled
+ (tramp-compat-user-error nil "Package `tramp-archive' not supported"))
+ (let ((tramp-methods (cons `(,tramp-archive-method) tramp-methods))
+ (tramp-gvfs-methods tramp-archive-all-gvfs-methods)
+ (fn (assoc operation tramp-archive-file-name-handler-alist)))
+ (when (eq (cdr fn) 'tramp-archive-handle-not-implemented)
+ (setq args (cons operation args)))
+ (if fn
+ (save-match-data (apply (cdr fn) args))
+ (tramp-run-real-handler operation args))))
+
+;; Mark `operations' the handler is responsible for.
+(put 'tramp-archive-file-name-handler 'operations
+ (mapcar 'car tramp-archive-file-name-handler-alist))
+
+;; `tramp-archive-file-name-handler' must be placed before `url-file-handler'.
+(when url-handler-mode (tramp-register-file-name-handlers))
+
+(eval-after-load 'url-handler
+ (progn
+ (add-hook 'url-handler-mode-hook 'tramp-register-file-name-handlers)
+ (add-hook
+ 'tramp-archive-unload-hook
+ (lambda ()
+ (remove-hook
+ 'url-handler-mode-hook 'tramp-register-file-name-handlers)))))
+
+;; Debug.
+;(trace-function-background 'tramp-archive-file-name-handler)
+;(trace-function-background 'tramp-gvfs-file-name-handler)
+;(trace-function-background 'tramp-file-name-archive)
+;(trace-function-background 'tramp-archive-dissect-file-name)
+
+
+;; File name conversions.
+
+(defun tramp-archive-file-name-p (name)
+ "Return t if NAME is a string with archive file name syntax."
+ (and (stringp name)
+ (string-match tramp-archive-file-name-regexp name)
+ t))
+
+(defvar tramp-archive-hash (make-hash-table :test 'equal)
+ "Hash table for archive local copies.")
+
+(defun tramp-archive-local-copy (archive)
+ "Return copy of ARCHIVE, usable by GVFS.
+ARCHIVE is the archive component of an archive file name."
+ (setq archive (file-truename archive))
+ (let ((tramp-verbose 0))
+ (with-tramp-connection-property
+ ;; This is just an auxiliary VEC for caching properties.
+ (make-tramp-file-name :method tramp-archive-method :host archive)
+ "archive"
+ (cond
+ ;; File archives inside file archives.
+ ((tramp-archive-file-name-p archive)
+ (let ((archive
+ (tramp-make-tramp-file-name
+ (tramp-archive-dissect-file-name archive) nil 'noarchive)))
+ ;; We call `file-attributes' in order to mount the archive.
+ (file-attributes archive)
+ (puthash archive nil tramp-archive-hash)
+ archive))
+ ;; http://...
+ ((and url-handler-mode
+ tramp-compat-use-url-tramp-p
+ (string-match url-handler-regexp archive)
+ (string-match "https?" (url-type (url-generic-parse-url archive))))
+ (let* ((url-tramp-protocols
+ (cons
+ (url-type (url-generic-parse-url archive))
+ url-tramp-protocols))
+ (archive (url-tramp-convert-url-to-tramp archive)))
+ (puthash archive nil tramp-archive-hash)
+ archive))
+ ;; GVFS supported schemes.
+ ((or (tramp-gvfs-file-name-p archive)
+ (not (file-remote-p archive)))
+ (puthash archive nil tramp-archive-hash)
+ archive)
+ ;; Anything else. Here we call `file-local-copy', which we
+ ;; have avoided so far.
+ (t (let ((inhibit-file-name-operation 'file-local-copy)
+ (inhibit-file-name-handlers
+ (cons 'jka-compr-handler inhibit-file-name-handlers))
+ result)
+ (or (and (setq result (gethash archive tramp-archive-hash nil))
+ (file-readable-p result))
+ (puthash
+ archive
+ (setq result (file-local-copy archive))
+ tramp-archive-hash))
+ result))))))
+
+;;;###tramp-autoload
+(defun tramp-archive-cleanup-hash ()
+ "Remove local copies of archives, used by GVFS."
+ (maphash
+ (lambda (key value)
+ ;; Unmount local copy.
+ (ignore-errors
+ (let ((tramp-gvfs-methods tramp-archive-all-gvfs-methods)
+ (file-archive (file-name-as-directory key)))
+ (tramp-message
+ (and (tramp-tramp-file-p key) (tramp-dissect-file-name key)) 3
+ "Unmounting %s" file-archive)
+ (tramp-gvfs-unmount
+ (tramp-dissect-file-name
+ (tramp-archive-gvfs-file-name file-archive)))))
+ ;; Delete local copy.
+ (ignore-errors (when value (delete-file value)))
+ (remhash key tramp-archive-hash))
+ tramp-archive-hash)
+ (clrhash tramp-archive-hash))
+
+(add-hook 'kill-emacs-hook 'tramp-archive-cleanup-hash)
+(add-hook 'tramp-archive-unload-hook
+ (lambda ()
+ (remove-hook 'kill-emacs-hook
+ 'tramp-archive-cleanup-hash)))
+
+(defun tramp-archive-dissect-file-name (name)
+ "Return a `tramp-file-name' structure.
+The structure consists of the `tramp-archive-method' method, the
+hexlified archive name as host, and the localname. The archive
+name is kept in slot `hop'"
+ (save-match-data
+ (unless (tramp-archive-file-name-p name)
+ (tramp-compat-user-error nil "Not an archive file name: \"%s\"" name))
+ ;; The `string-match' happened in `tramp-archive-file-name-p'.
+ (let ((archive (match-string 1 name))
+ (localname (match-string 2 name))
+ (tramp-verbose 0))
+ (make-tramp-file-name
+ :method tramp-archive-method :user nil :domain nil :host
+ (url-hexify-string
+ (tramp-gvfs-url-file-name (tramp-archive-local-copy archive)))
+ :port nil :localname localname :hop archive))))
+
+(defsubst tramp-file-name-archive (vec)
+ "Extract the archive file name from VEC.
+VEC is expected to be a `tramp-file-name', with the method being
+`tramp-archive-method', and the host being a coded URL. The
+archive name is extracted from the hop part of the VEC structure."
+ (and (tramp-file-name-p vec)
+ (string-equal (tramp-file-name-method vec) tramp-archive-method)
+ (tramp-file-name-hop vec)))
+
+(defmacro with-parsed-tramp-archive-file-name (filename var &rest body)
+ "Parse an archive filename and make components available in the body.
+This works exactly as `with-parsed-tramp-file-name' for the Tramp
+file name structure returned by `tramp-archive-dissect-file-name'.
+A variable `foo-archive' (or `archive') will be bound to the
+archive name part of FILENAME, assuming `foo' (or nil) is the
+value of VAR. OTOH, the variable `foo-hop' (or `hop') won't be
+offered."
+ (declare (debug (form symbolp body))
+ (indent 2))
+ (let ((bindings
+ (mapcar (lambda (elem)
+ `(,(if var (intern (format "%s-%s" var elem)) elem)
+ (,(intern (format "tramp-file-name-%s" elem))
+ ,(or var 'v))))
+ `,(cons
+ 'archive
+ (delete 'hop (tramp-compat-tramp-file-name-slots))))))
+ `(let* ((,(or var 'v) (tramp-archive-dissect-file-name ,filename))
+ ,@bindings)
+ ;; We don't know which of those vars will be used, so we bind them all,
+ ;; and then add here a dummy use of all those variables, so we don't get
+ ;; flooded by warnings about those vars `body' didn't use.
+ (ignore ,@(mapcar #'car bindings))
+ ,@body)))
+
+(defun tramp-archive-gvfs-file-name (name)
+ "Return FILENAME in GVFS syntax."
+ (tramp-make-tramp-file-name
+ (tramp-archive-dissect-file-name name) nil 'nohop))
+
+
+;; File name primitives.
+
+(defun tramp-archive-handle-copy-file
+ (filename newname &optional ok-if-already-exists keep-date
+ preserve-uid-gid preserve-extended-attributes)
+ "Like `copy-file' for file archives."
+ (when (tramp-archive-file-name-p newname)
+ (tramp-error
+ (tramp-archive-dissect-file-name newname) 'file-error
+ "Permission denied: %s" newname))
+ (copy-file
+ (tramp-archive-gvfs-file-name filename) newname ok-if-already-exists
+ keep-date preserve-uid-gid preserve-extended-attributes))
+
+(defun tramp-archive-handle-directory-file-name (directory)
+ "Like `directory-file-name' for file archives."
+ (with-parsed-tramp-archive-file-name directory nil
+ (if (and (not (zerop (length localname)))
+ (eq (aref localname (1- (length localname))) ?/)
+ (not (string= localname "/")))
+ (substring directory 0 -1)
+ ;; We do not want to leave the file archive. This would require
+ ;; unnecessary download of http-based file archives, for
+ ;; example. So we return `directory'.
+ directory)))
+
+(defun tramp-archive-handle-dired-uncache (dir)
+ "Like `dired-uncache' for file archives."
+ (dired-uncache (tramp-archive-gvfs-file-name dir)))
+
+(defun tramp-archive-handle-file-attributes (filename &optional id-format)
+ "Like `file-attributes' for file archives."
+ (file-attributes (tramp-archive-gvfs-file-name filename) id-format))
+
+(defun tramp-archive-handle-file-executable-p (filename)
+ "Like `file-executable-p' for file archives."
+ (file-executable-p (tramp-archive-gvfs-file-name filename)))
+
+(defun tramp-archive-handle-file-local-copy (filename)
+ "Like `file-local-copy' for file archives."
+ (file-local-copy (tramp-archive-gvfs-file-name filename)))
+
+(defun tramp-archive-handle-file-name-all-completions (filename directory)
+ "Like `file-name-all-completions' for file archives."
+ (file-name-all-completions filename (tramp-archive-gvfs-file-name directory)))
+
+(defun tramp-archive-handle-file-readable-p (filename)
+ "Like `file-readable-p' for file archives."
+ (with-parsed-tramp-file-name
+ (tramp-archive-gvfs-file-name filename) nil
+ (tramp-check-cached-permissions v ?r)))
+
+(defun tramp-archive-handle-file-system-info (filename)
+ "Like `file-system-info' for file archives."
+ (with-parsed-tramp-archive-file-name filename nil
+ (list (tramp-compat-file-attribute-size (file-attributes archive)) 0 0)))
+
+(defun tramp-archive-handle-file-truename (filename)
+ "Like `file-truename' for file archives."
+ (with-parsed-tramp-archive-file-name filename nil
+ (let ((local (or (file-symlink-p filename) localname)))
+ (unless (file-name-absolute-p local)
+ (setq local (expand-file-name local (file-name-directory localname))))
+ (concat (file-truename archive) local))))
+
+(defun tramp-archive-handle-insert-directory
+ (filename switches &optional wildcard full-directory-p)
+ "Like `insert-directory' for file archives."
+ (insert-directory
+ (tramp-archive-gvfs-file-name filename) switches wildcard full-directory-p)
+ (goto-char (point-min))
+ (while (search-forward (tramp-archive-gvfs-file-name filename) nil 'noerror)
+ (replace-match filename)))
+
+(defun tramp-archive-handle-insert-file-contents
+ (filename &optional visit beg end replace)
+ "Like `insert-file-contents' for file archives."
+ (let ((result
+ (insert-file-contents
+ (tramp-archive-gvfs-file-name filename) visit beg end replace)))
+ (prog1
+ (list (expand-file-name filename)
+ (cadr result))
+ (when visit (setq buffer-file-name filename)))))
+
+(defun tramp-archive-handle-load
+ (file &optional noerror nomessage nosuffix must-suffix)
+ "Like `load' for file archives."
+ (load
+ (tramp-archive-gvfs-file-name file) noerror nomessage nosuffix must-suffix))
+
+(defun tramp-archive-handle-temporary-file-directory ()
+ "Like `temporary-file-directory' for Tramp files."
+ ;; 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)))
+ (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-file-name-for-operation operation args)))))
+ (tramp-message v 10 "%s" (cons operation args))
+ (tramp-error
+ v 'file-error
+ "Operation `%s' not implemented for file archives" operation)))
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-archive 'force)))
+
+(provide 'tramp-archive)
+
+;;; TODO:
+
+;; * See, whether we could retrieve better file attributes like uid,
+;; gid, permissions.
+;;
+;; * Implement write access, when possible.
+
+;;; tramp-archive.el ends here
diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el
index dc97501be3d..56f3f28c5c3 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)))
@@ -169,7 +166,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 +196,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 +218,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 +237,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 +306,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 +416,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 78ef1a3ef40..ed36761ed96 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,9 @@ This includes password cache, file cache, connection cache, buffers."
;; Flush file and connection cache.
(clrhash tramp-cache-data)
+ ;; Cleanup local copies of archives.
+ (tramp-archive-cleanup-hash)
+
;; Remove buffers.
(dolist (name (tramp-list-tramp-buffers))
(when (bufferp (get-buffer name)) (kill-buffer name))))
diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el
index 9cdfc065128..a9e9ce85d68 100644
--- a/lisp/net/tramp-compat.el
+++ b/lisp/net/tramp-compat.el
@@ -190,11 +190,6 @@ This is a string of ten letters or dashes as in ls -l."
(if (get 'file-missing 'error-conditions) 'file-missing 'file-error)
"The error symbol for the `file-missing' error.")
-(add-hook 'tramp-unload-hook
- (lambda ()
- (unload-feature 'tramp-loaddefs 'force)
- (unload-feature 'tramp-compat 'force)))
-
;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' are
;; introduced in Emacs 26.
(eval-and-compile
@@ -243,6 +238,17 @@ If NAME is a remote file name, the local part of NAME is unquoted."
`(cdr (mapcar 'car (cl-struct-slot-info 'tramp-file-name)))
`(cdr (mapcar 'car (get 'tramp-file-name 'cl-struct-slots)))))
+;; The signature of `tramp-make-tramp-file-name' has been changed.
+;; Therefore, we cannot us `url-tramp-convert-url-to-tramp' prior
+;; Emacs 26.1. We use `temporary-file-directory' as indicator.
+(defconst tramp-compat-use-url-tramp-p (fboundp 'temporary-file-directory)
+ "Whether to use url-tramp.el.")
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-loaddefs 'force)
+ (unload-feature 'tramp-compat 'force)))
+
(provide 'tramp-compat)
;;; TODO:
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index 1d1b04b44f8..a65b8e96d53 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -54,10 +54,12 @@
;; device, if it hasn't been done already. There might be also some
;; few seconds delay in discovering available bluetooth devices.
-;; Other possible connection methods are "ftp" and "smb". When one of
-;; these methods is added to the list, the remote access for that
-;; method is performed via GVFS instead of the native Tramp
-;; implementation.
+;; Other possible connection methods are "ftp", "http", "https" and
+;; "smb". When one of these methods is added to the list, the remote
+;; access for that method is performed via GVFS instead of the native
+;; Tramp implementation. However, this is not recommended. These
+;; methods are listed here for the benefit of file archives, see
+;; tramp-archive.el.
;; GVFS offers even more connection methods. The complete list of
;; connection methods of the actual GVFS implementation can be
@@ -119,6 +121,8 @@
(const "davs")
(const "ftp")
(const "gdrive")
+ (const "http")
+ (const "https")
(const "obex")
(const "sftp")
(const "smb")
@@ -424,11 +428,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"
@@ -495,7 +501,7 @@ Every entry is a list (NAME ADDRESS).")
(file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
(file-acl . ignore)
(file-attributes . tramp-gvfs-handle-file-attributes)
- (file-directory-p . tramp-gvfs-handle-file-directory-p)
+ (file-directory-p . tramp-handle-file-directory-p)
(file-equal-p . tramp-handle-file-equal-p)
(file-executable-p . tramp-gvfs-handle-file-executable-p)
(file-exists-p . tramp-handle-file-exists-p)
@@ -642,7 +648,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 +681,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 +745,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 +785,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 +800,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 +1050,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
@@ -1178,7 +1180,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 +1205,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 +1262,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))
@@ -1363,13 +1365,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.
@@ -1464,6 +1460,8 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
(cadr (assoc "port" (cadr mount-spec)))))
(ssl (tramp-gvfs-dbus-byte-array-to-string
(cadr (assoc "ssl" (cadr mount-spec)))))
+ (uri (tramp-gvfs-dbus-byte-array-to-string
+ (cadr (assoc "uri" (cadr mount-spec)))))
(prefix (concat
(tramp-gvfs-dbus-byte-array-to-string
(car mount-spec))
@@ -1478,14 +1476,20 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
(setq method "davs"))
(when (string-equal "google-drive" method)
(setq method "gdrive"))
+ (when (and (string-equal "http" method) (stringp uri))
+ (setq uri (url-generic-parse-url uri)
+ method (url-type uri)
+ user (url-user uri)
+ host (url-host uri)
+ port (url-portspec uri)))
(with-parsed-tramp-file-name
(tramp-make-tramp-file-name method user domain host port "") nil
(tramp-message
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 "/")
+ (tramp-flush-file-properties v "/")
;; Set prefix, mountpoint and location.
(unless (string-equal prefix "/")
(tramp-set-file-property v "/" "prefix" prefix))
@@ -1546,6 +1550,8 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
(cadr (assoc "port" (cadr mount-spec)))))
(ssl (tramp-gvfs-dbus-byte-array-to-string
(cadr (assoc "ssl" (cadr mount-spec)))))
+ (uri (tramp-gvfs-dbus-byte-array-to-string
+ (cadr (assoc "uri" (cadr mount-spec)))))
(prefix (concat
(tramp-gvfs-dbus-byte-array-to-string
(car mount-spec))
@@ -1563,6 +1569,12 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
(setq method "gdrive"))
(when (and (string-equal "synce" method) (zerop (length user)))
(setq user (or (tramp-file-name-user vec) "")))
+ (when (and (string-equal "http" method) (stringp uri))
+ (setq uri (url-generic-parse-url uri)
+ method (url-type uri)
+ user (url-user uri)
+ host (url-host uri)
+ port (url-portspec uri)))
(when (and
(string-equal method (tramp-file-name-method vec))
(string-equal user (tramp-file-name-user vec))
@@ -1579,6 +1591,16 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"."
vec "default-location" default-location)
(throw 'mounted t)))))))
+(defun tramp-gvfs-unmount (vec)
+ "Unmount the object identified by VEC."
+ (let ((vec (copy-tramp-file-name vec)))
+ (setf (tramp-file-name-localname vec) "/"
+ (tramp-file-name-hop vec) nil)
+ (when (tramp-gvfs-connection-mounted-p vec)
+ (tramp-gvfs-send-command
+ vec "gvfs-mount" "-u"
+ (tramp-gvfs-url-file-name (tramp-make-tramp-file-name vec))))))
+
(defun tramp-gvfs-mount-spec-entry (key value)
"Construct a mount-spec entry to be used in a mount_spec.
It was \"a(say)\", but has changed to \"a{sv})\"."
@@ -1620,7 +1642,14 @@ It was \"a(say)\", but has changed to \"a{sv})\"."
((string-equal "gdrive" method)
(list (tramp-gvfs-mount-spec-entry "type" "google-drive")
(tramp-gvfs-mount-spec-entry "host" host)))
- (t
+ ((string-match "\\`http" method)
+ (list (tramp-gvfs-mount-spec-entry "type" "http")
+ (tramp-gvfs-mount-spec-entry
+ "uri"
+ (url-recreate-url
+ (url-parse-make-urlobj
+ method user nil host port "/" nil nil t)))))
+ (t
(list (tramp-gvfs-mount-spec-entry "type" method)
(tramp-gvfs-mount-spec-entry "host" host))))
,@(when user
@@ -1836,7 +1865,7 @@ 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 BLUEZ functions.
@@ -2042,6 +2071,8 @@ They are retrieved from the hal daemon."
;;; TODO:
+;; * (Customizable) unmount when exiting Emacs. See tramp-archive.el.
+
;; * Host name completion for existing mount points (afp-server,
;; smb-server) or via smb-network.
;;
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 14c1a4049aa..96a0d849072 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -1104,8 +1104,8 @@ component is used as the target of the symlink."
(tramp-error v 'file-already-exists localname)
(delete-file linkname)))
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
;; Right, they are on the same host, regardless of user,
;; method, etc. We now make the link on the remote
@@ -1500,8 +1500,8 @@ of."
(defun tramp-sh-handle-set-file-modes (filename mode)
"Like `set-file-modes' for Tramp files."
(with-parsed-tramp-file-name filename nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
;; FIXME: extract the proper text from chmod's stderr.
(tramp-barf-unless-okay
v
@@ -1512,8 +1512,8 @@ of."
"Like `set-file-times' for Tramp files."
(with-parsed-tramp-file-name filename nil
(when (tramp-get-remote-touch v)
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
(let ((time (if (or (null time) (equal time '(0 0)))
(current-time)
time)))
@@ -1605,8 +1605,7 @@ be non-negative integers."
(if (and user role type range)
(tramp-set-file-property
v localname "file-selinux-context" context)
- (tramp-set-file-property
- v localname "file-selinux-context" 'undef))
+ (tramp-flush-file-property v localname "file-selinux-context"))
t)))))
(defun tramp-remote-acl-p (vec)
@@ -1646,7 +1645,7 @@ be non-negative integers."
(tramp-set-file-property v localname "file-acl" acl-string)
t)
;; In case of errors, we return nil.
- (tramp-set-file-property v localname "file-acl-string" 'undef)
+ (tramp-flush-file-property v localname "file-acl-string")
nil)))
;; Simple functions using the `test' command.
@@ -1940,8 +1939,8 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'"
v2-localname)))))
(tramp-error v2 'file-already-exists newname)
(delete-file newname)))
- (tramp-flush-file-property v2 (file-name-directory v2-localname))
- (tramp-flush-file-property v2 v2-localname)
+ (tramp-flush-file-properties v2 (file-name-directory v2-localname))
+ (tramp-flush-file-properties v2 v2-localname)
(tramp-barf-unless-okay
v1
(format "%s %s %s" ln
@@ -2007,8 +2006,8 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'"
;; When newname did exist, we have wrong cached values.
(when t2
(with-parsed-tramp-file-name newname nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname))))))
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname))))))
(defun tramp-sh-handle-rename-file
(filename newname &optional ok-if-already-exists)
@@ -2133,14 +2132,16 @@ file names."
;; In case of `rename', we must flush the cache of the source file.
(when (and t1 (eq op 'rename))
(with-parsed-tramp-file-name filename v1
- (tramp-flush-file-property v1 (file-name-directory v1-localname))
- (tramp-flush-file-property v1 v1-localname)))
+ (tramp-flush-file-properties
+ v1 (file-name-directory v1-localname))
+ (tramp-flush-file-properties v1 v1-localname)))
;; When newname did exist, we have wrong cached values.
(when t2
(with-parsed-tramp-file-name newname v2
- (tramp-flush-file-property v2 (file-name-directory v2-localname))
- (tramp-flush-file-property v2 v2-localname))))))))
+ (tramp-flush-file-properties
+ v2 (file-name-directory v2-localname))
+ (tramp-flush-file-properties v2 v2-localname))))))))
(defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date)
"Use an Emacs buffer to copy or rename a file.
@@ -2362,15 +2363,6 @@ The method used must be an out-of-band method."
(expand-file-name ".." tmpfile) 'recursive)
(delete-file tmpfile)))))
- ;; Set variables for computing the prompt for reading password.
- (setq tramp-current-method (tramp-file-name-method v)
- tramp-current-user (or (tramp-file-name-user v)
- (tramp-get-connection-property
- v "login-as" nil))
- tramp-current-domain (tramp-file-name-domain v)
- tramp-current-host (tramp-file-name-host v)
- tramp-current-port (tramp-file-name-port v))
-
;; Check which ones of source and target are Tramp files.
(setq source (funcall
(if (and (file-directory-p filename)
@@ -2481,7 +2473,9 @@ The method used must be an out-of-band method."
;; The default directory must be remote.
(let ((default-directory
(file-name-directory (if t1 filename newname)))
- (process-environment (copy-sequence process-environment)))
+ (process-environment (copy-sequence process-environment))
+ ;; We do not want to run timers.
+ timer-list timer-idle-list)
;; Set the transfer process properties.
(tramp-set-connection-property
v "process-name" (buffer-name (current-buffer)))
@@ -2524,8 +2518,8 @@ The method used must be an out-of-band method."
p v nil tramp-actions-copy-out-of-band))))
;; Reset the transfer process properties.
- (tramp-set-connection-property v "process-name" nil)
- (tramp-set-connection-property v "process-buffer" nil)
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer")
;; Clear the remote prompt.
(when (and remote-copy-program
(not (tramp-send-command-and-check v nil)))
@@ -2556,7 +2550,7 @@ The method used must be an out-of-band method."
"Like `make-directory' for Tramp files."
(setq dir (expand-file-name dir))
(with-parsed-tramp-file-name dir nil
- (tramp-flush-directory-property v (file-name-directory localname))
+ (tramp-flush-directory-properties v (file-name-directory localname))
(save-excursion
(tramp-barf-unless-okay
v (format "%s %s"
@@ -2568,8 +2562,8 @@ The method used must be an out-of-band method."
"Like `delete-directory' for Tramp files."
(setq directory (expand-file-name directory))
(with-parsed-tramp-file-name directory nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-directory-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-directory-properties v localname)
(tramp-barf-unless-okay
v (format "cd / && %s %s"
(or (and trash (tramp-get-remote-trash v))
@@ -2581,8 +2575,8 @@ The method used must be an out-of-band method."
"Like `delete-file' for Tramp files."
(setq filename (expand-file-name filename))
(with-parsed-tramp-file-name filename nil
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
(tramp-barf-unless-okay
v (format "%s %s"
(or (and trash (tramp-get-remote-trash v)) "rm -f")
@@ -2595,7 +2589,7 @@ The method used must be an out-of-band method."
"Like `dired-compress-file' for Tramp files."
;; Code stolen mainly from dired-aux.el.
(with-parsed-tramp-file-name file nil
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v localname)
(save-excursion
(let ((suffixes dired-compress-file-suffixes)
suffix)
@@ -2831,8 +2825,8 @@ the result will be a local, non-Tramp, file name."
(let ((vec (tramp-get-connection-property proc "vector" nil)))
(when vec
(tramp-message vec 5 "Sentinel called: `%S' `%s'" proc event)
- (tramp-flush-connection-property proc)
- (tramp-flush-directory-property vec "")))))
+ (tramp-flush-connection-properties proc)
+ (tramp-flush-directory-properties vec "")))))
;; We use BUFFER also as connection buffer during setup. Because of
;; this, its original contents must be saved, and restored once
@@ -2866,13 +2860,7 @@ the result will be a local, non-Tramp, file name."
;; We discard hops, if existing, that's why we cannot use
;; `file-remote-p'.
(prompt (format "PS1=%s %s"
- (tramp-make-tramp-file-name
- (tramp-file-name-method v)
- (tramp-file-name-user v)
- (tramp-file-name-domain v)
- (tramp-file-name-host v)
- (tramp-file-name-port v)
- (tramp-file-name-localname v))
+ (tramp-make-tramp-file-name v nil 'nohop)
tramp-initial-end-of-output))
;; We use as environment the difference to toplevel
;; `process-environment'.
@@ -2908,7 +2896,9 @@ the result will be a local, non-Tramp, file name."
;; We do not want to raise an error when
;; `start-file-process' has been started several times in
;; `eshell' and friends.
- (tramp-current-connection nil)
+ tramp-current-connection
+ ;; We do not want to run timers.
+ timer-list timer-idle-list
p)
(while (get-process name1)
@@ -2972,8 +2962,8 @@ the result will be a local, non-Tramp, file name."
(set-process-buffer p nil)
(kill-buffer (current-buffer)))
(set-buffer-modified-p bmp))
- (tramp-set-connection-property v "process-name" nil)
- (tramp-set-connection-property v "process-buffer" nil))))))
+ (tramp-flush-connection-property v "process-name")
+ (tramp-flush-connection-property v "process-buffer"))))))
(defun tramp-sh-handle-process-file
(program &optional infile destination display &rest args)
@@ -3095,7 +3085,7 @@ the result will be a local, non-Tramp, file name."
(when tmpinput (delete-file tmpinput))
(unless process-file-side-effects
- (tramp-flush-directory-property v ""))
+ (tramp-flush-directory-properties v ""))
;; Return exit status.
(if (equal ret -1)
@@ -3399,8 +3389,8 @@ the result will be a local, non-Tramp, file name."
(when coding-system-used
(set 'last-coding-system-used coding-system-used))))
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
;; We must protect `last-coding-system-used', now we have set it
;; to its correct value.
@@ -4755,8 +4745,7 @@ connection if a previous connection has died for some reason."
(set-process-sentinel p 'tramp-process-sentinel)
(process-put p 'adjust-window-size-function 'ignore)
(set-process-query-on-exit-flag p nil)
- (setq tramp-current-connection (cons vec (current-time))
- tramp-current-host (system-name))
+ (setq tramp-current-connection (cons vec (current-time)))
(tramp-message
vec 6 "%s" (mapconcat 'identity (process-command p) " "))
@@ -4810,16 +4799,15 @@ connection if a previous connection has died for some reason."
;; Check, whether there is a restricted shell.
(dolist (elt tramp-restricted-shell-hosts-alist)
- (when (string-match elt tramp-current-host)
+ (when (string-match elt l-host)
(setq r-shell t)))
- ;; Set variables for computing the prompt for
- ;; reading password.
- (setq tramp-current-method l-method
- tramp-current-user l-user
- tramp-current-domain l-domain
- tramp-current-host l-host
- tramp-current-port l-port)
+ ;; Set password prompt vector.
+ (tramp-set-connection-property
+ p "password-vector"
+ (make-tramp-file-name
+ :method l-method :user l-user :domain l-domain
+ :host l-host :port l-port))
;; Add login environment.
(when login-env
@@ -5244,14 +5232,7 @@ Nonexistent directories are removed from spec."
(lambda (x)
(and
(stringp x)
- (file-directory-p
- (tramp-make-tramp-file-name
- (tramp-file-name-method vec)
- (tramp-file-name-user vec)
- (tramp-file-name-domain vec)
- (tramp-file-name-host vec)
- (tramp-file-name-port vec)
- x))
+ (file-directory-p (tramp-make-tramp-file-name vec x))
x))
remote-path)))))
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index a4d4b4e0bcf..fee14df991e 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -228,10 +228,10 @@ See `tramp-actions-before-shell' for more info.")
(dired-compress-file . ignore)
(dired-uncache . tramp-handle-dired-uncache)
(expand-file-name . tramp-smb-handle-expand-file-name)
- (file-accessible-directory-p . tramp-smb-handle-file-directory-p)
+ (file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
(file-acl . tramp-smb-handle-file-acl)
(file-attributes . tramp-smb-handle-file-attributes)
- (file-directory-p . tramp-smb-handle-file-directory-p)
+ (file-directory-p . tramp-handle-file-directory-p)
(file-file-equal-p . tramp-handle-file-equal-p)
(file-executable-p . tramp-handle-file-exists-p)
(file-exists-p . tramp-handle-file-exists-p)
@@ -370,8 +370,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 +449,6 @@ pass to the OPERATION."
(if (not (file-directory-p newname))
(make-directory newname parents))
- ;; Set variables for computing the prompt for reading password.
- (setq tramp-current-method method
- tramp-current-user user
- tramp-current-domain domain
- tramp-current-host host
- tramp-current-port port)
-
(let* ((share (tramp-smb-get-share v))
(localname (file-name-as-directory
(replace-regexp-in-string
@@ -464,7 +457,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)))
@@ -534,8 +529,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 +547,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 +593,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 +628,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 +649,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 +734,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) " "))
+ (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-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 +902,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 +1148,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 +1195,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 +1206,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 +1219,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 +1313,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 +1356,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 +1389,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)))
@@ -1470,14 +1452,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 +1479,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 +1514,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 +1548,8 @@ errors for shares like \"C$/\", which are common in Microsoft Windows."
;; We must also flush the cache of the directory, because
;; `file-attributes' reads the values from there.
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
+ (tramp-flush-file-properties v (file-name-directory localname))
+ (tramp-flush-file-properties v localname)
(let ((curbuf (current-buffer))
(tmpfile (tramp-compat-make-temp-file filename)))
(when (and append (file-exists-p filename))
@@ -1889,8 +1873,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)))
@@ -1971,13 +1955,6 @@ If ARGUMENT is non-nil, use it as argument for
(process-put p 'adjust-window-size-function 'ignore)
(set-process-query-on-exit-flag p nil)
- ;; Set variables for computing the prompt for reading password.
- (setq tramp-current-method tramp-smb-method
- tramp-current-user user
- tramp-current-domain domain
- tramp-current-host host
- tramp-current-port port)
-
(condition-case err
(let (tramp-message-show-message)
;; Play login scenario.
@@ -1998,8 +1975,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 1695eea06cc..01a3e44c73e 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -1182,21 +1182,6 @@ means to use always cached values for the directory contents."
;;; Internal Variables:
-(defvar tramp-current-method nil
- "Connection method for this *tramp* buffer.")
-
-(defvar tramp-current-user nil
- "Remote login name for this *tramp* buffer.")
-
-(defvar tramp-current-domain nil
- "Remote domain name for this *tramp* buffer.")
-
-(defvar tramp-current-host nil
- "Remote host for this *tramp* buffer.")
-
-(defvar tramp-current-port nil
- "Remote port for this *tramp* buffer.")
-
(defvar tramp-current-connection nil
"Last connection timestamp.")
@@ -1390,7 +1375,7 @@ values."
(make-tramp-file-name
:method method :user user :domain domain :host host :port port
- :localname (or localname "") :hop hop)))))
+ :localname localname :hop hop)))))
(defun tramp-buffer-name (vec)
"A name for the connection buffer VEC."
@@ -1401,30 +1386,64 @@ values."
(format "*tramp/%s %s@%s*" method user-domain host-port)
(format "*tramp/%s %s*" method host-port))))
-(defun tramp-make-tramp-file-name
- (method user domain host port localname &optional hop)
- "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME.
-When not nil, optional DOMAIN, PORT and HOP are used."
- (concat tramp-prefix-format hop
- (unless (or (zerop (length method))
- (zerop (length tramp-postfix-method-format)))
- (concat method tramp-postfix-method-format))
- user
- (unless (zerop (length domain))
- (concat tramp-prefix-domain-format domain))
- (unless (zerop (length user))
- tramp-postfix-user-format)
- (when host
- (if (string-match tramp-ipv6-regexp host)
- (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format)
- host))
- (unless (zerop (length port))
- (concat tramp-prefix-port-format port))
- tramp-postfix-host-format
- (when localname localname)))
+(defun tramp-make-tramp-file-name (&rest args)
+ "Construct a Tramp file name from ARGS.
+
+ARGS could have two different signatures. The first one is of
+type (VEC &optional LOCALNAME HOP).
+If LOCALNAME is nil, the value in VEC is used. If it is a
+symbol, a null localname will be used. Otherwise, LOCALNAME is
+expected to be a string, which will be used.
+If HOP is nil, the value in VEC is used. If it is a symbol, a
+null hop will be used. Otherwise, HOP is expected to be a
+string, which will be used.
+
+The other signature exists for backward compatibility. It has
+the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)."
+ (let (method user domain host port localname hop)
+ (cond
+ ((tramp-file-name-p (car args))
+ (setq method (tramp-file-name-method (car args))
+ user (tramp-file-name-user (car args))
+ domain (tramp-file-name-domain (car args))
+ host (tramp-file-name-host (car args))
+ port (tramp-file-name-port (car args))
+ localname (tramp-file-name-localname (car args))
+ hop (tramp-file-name-hop (car args)))
+ (when (cadr args)
+ (setq localname (and (stringp (cadr args)) (cadr args))))
+ (when (cl-caddr args)
+ (setq hop (and (stringp (cl-caddr args)) (cl-caddr args)))))
+
+ (t (setq method (nth 0 args)
+ user (nth 1 args)
+ domain (nth 2 args)
+ host (nth 3 args)
+ port (nth 4 args)
+ localname (nth 5 args)
+ hop (nth 6 args))))
+
+ (concat tramp-prefix-format hop
+ (unless (or (zerop (length method))
+ (zerop (length tramp-postfix-method-format)))
+ (concat method tramp-postfix-method-format))
+ user
+ (unless (zerop (length domain))
+ (concat tramp-prefix-domain-format domain))
+ (unless (zerop (length user))
+ tramp-postfix-user-format)
+ (when host
+ (if (string-match tramp-ipv6-regexp host)
+ (concat
+ tramp-prefix-ipv6-format host tramp-postfix-ipv6-format)
+ host))
+ (unless (zerop (length port))
+ (concat tramp-prefix-port-format port))
+ tramp-postfix-host-format
+ localname)))
(defun tramp-completion-make-tramp-file-name (method user host localname)
- "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME.
+ "Construct a Tramp file name from METHOD, USER, HOST and LOCALNAME.
It must not be a complete Tramp file name, but as long as there are
necessary only. This function will be used in file name completion."
(concat tramp-prefix-format
@@ -1451,15 +1470,8 @@ necessary only. This function will be used in file name completion."
(tramp-set-connection-property
vec "process-buffer"
(tramp-get-connection-property vec "process-buffer" nil))
- (setq buffer-undo-list t)
- (setq default-directory
- (tramp-make-tramp-file-name
- (tramp-file-name-method vec)
- (tramp-file-name-user vec)
- (tramp-file-name-domain vec)
- (tramp-file-name-host vec)
- (tramp-file-name-port vec)
- "/"))
+ (setq buffer-undo-list t
+ default-directory (tramp-make-tramp-file-name vec "/" 'nohop))
(current-buffer))))
(defun tramp-get-connection-buffer (vec)
@@ -2052,6 +2064,7 @@ pass to the OPERATION."
`(tramp-file-name-handler
tramp-vc-file-name-handler
tramp-completion-file-name-handler
+ tramp-archive-file-name-handler
cygwin-mount-name-hook-function
cygwin-mount-map-drive-hook-function
.
@@ -2352,15 +2365,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 +2391,11 @@ remote file names."
(put 'tramp-completion-file-name-handler 'operations
(mapcar 'car tramp-completion-file-name-handler-alist))
+ (add-to-list 'file-name-handler-alist
+ (cons tramp-archive-file-name-regexp
+ 'tramp-archive-file-name-handler))
+ (put 'tramp-archive-file-name-handler 'safe-magic t)
+
;; If jka-compr or epa-file are already loaded, move them to the
;; front of `file-name-handler-alist'.
(dolist (fnh '(epa-file-handler jka-compr-handler))
@@ -2427,6 +2449,7 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'."
"Unload Tramp file name handlers from `file-name-handler-alist'."
(dolist (fnh '(tramp-file-name-handler
tramp-completion-file-name-handler
+ tramp-archive-file-name-handler
tramp-autoload-file-name-handler))
(let ((a1 (rassq fnh file-name-handler-alist)))
(setq file-name-handler-alist (delq a1 file-name-handler-alist))))))
@@ -2488,7 +2511,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 +2948,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 +2993,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 +3046,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 +3109,6 @@ User is always nil."
(defun tramp-handle-file-name-completion
(filename directory &optional predicate)
"Like `file-name-completion' for Tramp files."
- (unless (tramp-tramp-file-p directory)
- (error
- "tramp-handle-file-name-completion invoked on non-tramp directory `%s'"
- directory))
(let (hits-ignored-extensions)
(or
(try-completion
@@ -3116,14 +3134,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 +3174,8 @@ User is always nil."
(and (or (not connected) c)
(cond
((eq identification 'method) method)
- ;; Domain and port are appended.
+ ;; Domain and port are appended to user and host,
+ ;; respectively.
((eq identification 'user) (tramp-file-name-user-domain v))
((eq identification 'host) (tramp-file-name-host-port v))
((eq identification 'localname) localname)
@@ -3574,29 +3587,28 @@ of."
(eq (visited-file-modtime) 0)
(not (file-remote-p f nil 'connected)))
t
- (with-parsed-tramp-file-name f nil
- (let* ((remote-file-name-inhibit-cache t)
- (attr (file-attributes f))
- (modtime (tramp-compat-file-attribute-modification-time attr))
- (mt (visited-file-modtime)))
-
- (cond
- ;; File exists, and has a known modtime.
- ((and attr (not (equal modtime '(0 0))))
- (< (abs (tramp-time-diff
- modtime
- ;; For compatibility, deal with both the old
- ;; (HIGH . LOW) and the new (HIGH LOW) return
- ;; values of `visited-file-modtime'.
- (if (atom (cdr mt))
- (list (car mt) (cdr mt))
- mt)))
- 2))
- ;; Modtime has the don't know value.
- (attr t)
- ;; If file does not exist, say it is not modified if and
- ;; only if that agrees with the buffer's record.
- (t (equal mt '(-1 65535))))))))))
+ (let* ((remote-file-name-inhibit-cache t)
+ (attr (file-attributes f))
+ (modtime (tramp-compat-file-attribute-modification-time attr))
+ (mt (visited-file-modtime)))
+
+ (cond
+ ;; File exists, and has a known modtime.
+ ((and attr (not (equal modtime '(0 0))))
+ (< (abs (tramp-time-diff
+ modtime
+ ;; For compatibility, deal with both the old
+ ;; (HIGH . LOW) and the new (HIGH LOW) return
+ ;; values of `visited-file-modtime'.
+ (if (atom (cdr mt))
+ (list (car mt) (cdr mt))
+ mt)))
+ 2))
+ ;; Modtime has the don't know value.
+ (attr t)
+ ;; If file does not exist, say it is not modified if and
+ ;; only if that agrees with the buffer's record.
+ (t (equal mt '(-1 65535)))))))))
(defun tramp-handle-file-notify-add-watch (filename _flags _callback)
"Like `file-notify-add-watch' for Tramp files."
@@ -3633,17 +3645,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 +3778,11 @@ PROC and VEC indicate the remote connection to be used. POS, if
set, is the starting point of the region to be deleted in the
connection buffer."
;; Enable `auth-source', unless "emacs -Q" has been called. We must
- ;; use `tramp-current-*' variables in case we have several hops.
+ ;; use the "password-vector" property in case we have several hops.
(tramp-set-connection-property
- (make-tramp-file-name
- :method tramp-current-method :user tramp-current-user
- :domain tramp-current-domain :host tramp-current-host
- :port tramp-current-port)
+ (tramp-get-connection-property
+ proc "password-vector"
+ (tramp-get-connection-property proc "vector" nil))
"first-password-request" tramp-cache-read-persistent-data)
(save-restriction
(with-tramp-progress-reporter
@@ -3823,7 +3833,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 +4152,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 +4209,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 +4219,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 +4334,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 +4355,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 +4366,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 +4382,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 +4396,13 @@ Consults the auth-source package.
Invokes `password-read' if available, `read-passwd' else."
(let* ((case-fold-search t)
(key (tramp-make-tramp-file-name
- tramp-current-method tramp-current-user tramp-current-domain
- tramp-current-host tramp-current-port ""))
+ ;; In tramp-sh.el, we must use "password-vector" due to
+ ;; multi-hop.
+ (tramp-get-connection-property
+ proc "password-vector"
+ ;; All other backends simply use "vector".
+ (tramp-get-connection-property proc "vector" nil))
+ 'noloc 'nohop))
(pw-prompt
(or prompt
(with-current-buffer (process-buffer proc)
@@ -4424,6 +4414,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 +4426,16 @@ Invokes `password-read' if available, `read-passwd' else."
(setq auth-info
(auth-source-search
:max 1
- (and tramp-current-user :user)
- (if tramp-current-domain
- (format
- "%s%s%s"
- tramp-current-user tramp-prefix-domain-format
- tramp-current-domain)
- tramp-current-user)
+ (and user :user)
+ (if domain
+ (concat user tramp-prefix-domain-format domain)
+ user)
:host
- (if tramp-current-port
- (format
- "%s%s%s"
- tramp-current-host tramp-prefix-port-format
- tramp-current-port)
- tramp-current-host)
- :port tramp-current-method
- :require
- (cons
- :secret (and tramp-current-user '(:user))))
+ (if port
+ (concat host tramp-prefix-port-format port)
+ host)
+ :port method
+ :require (cons :secret (and user '(:user))))
auth-passwd (plist-get
(nth 0 auth-info) :secret)
auth-passwd (if (functionp auth-passwd)
@@ -4471,11 +4455,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 +4470,7 @@ Invokes `password-read' if available, `read-passwd' else."
(auth-source-forget
`(:max 1 ,(and user-domain :user) ,user-domain
:host ,host-port :port ,method))
- (password-cache-remove
- (tramp-make-tramp-file-name method user domain host port ""))))
+ (password-cache-remove (tramp-make-tramp-file-name vec 'noloc 'nohop))))
;; Snarfed code from time-date.el.
diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el
index 318e3351237..4506698c368 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,7 +55,7 @@
;; Check for Emacs version.
(let ((x (if (>= emacs-major-version 24)
"ok"
- (format "Tramp 2.3.3.26.1 is not fit for %s"
+ (format "Tramp 2.4.0-pre is not fit for %s"
(when (string-match "^.*$" (emacs-version))
(match-string 0 (emacs-version)))))))
(unless (string-match "\\`ok\\'" x) (error "%s" x)))
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-26 14:14:09 +0000