diff options
Diffstat (limited to 'lisp/net')
54 files changed, 5053 insertions, 3981 deletions
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index 9b23b8a4d89..37df7930469 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -1,4 +1,4 @@ -;;; ange-ftp.el --- transparent FTP support for GNU Emacs +;;; ange-ftp.el --- transparent FTP support for GNU Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1989-1996, 1998, 2000-2018 Free Software Foundation, ;; Inc. @@ -1168,7 +1168,7 @@ only return the directory part of FILE." (ange-ftp-parse-netrc) (catch 'found-one (maphash - (lambda (host val) + (lambda (host _val) (if (ange-ftp-lookup-passwd host user) (throw 'found-one host))) ange-ftp-user-hashtable) (save-match-data @@ -1361,11 +1361,13 @@ only return the directory part of FILE." (ange-ftp-real-expand-file-name ange-ftp-netrc-filename))) (setq attr (ange-ftp-real-file-attributes file))) (if (and attr ; file exists. - (not (equal (nth 5 attr) ange-ftp-netrc-modtime))) ; file changed + (not (equal (file-attribute-modification-time attr) + ange-ftp-netrc-modtime))) ; file changed (save-match-data (if (or ange-ftp-disable-netrc-security-check - (and (eq (nth 2 attr) (user-uid)) ; Same uids. - (string-match ".r..------" (nth 8 attr)))) + (and (eq (file-attribute-user-id attr) (user-uid)) ; Same uids. + (string-match ".r..------" + (file-attribute-modes attr)))) (with-current-buffer ;; we are cheating a bit here. I'm trying to do the equivalent ;; of find-file on the .netrc file, but then nuke it afterwards. @@ -1389,7 +1391,8 @@ only return the directory part of FILE." (ange-ftp-message "%s either not owned by you or badly protected." ange-ftp-netrc-filename) (sit-for 1)) - (setq ange-ftp-netrc-modtime (nth 5 attr)))))) + (setq ange-ftp-netrc-modtime + (file-attribute-modification-time attr)))))) ;; Return a list of prefixes of the form 'user@host:' to be used when ;; completion is done in the root directory. @@ -1399,14 +1402,14 @@ only return the directory part of FILE." (save-match-data (let (res) (maphash - (lambda (key value) + (lambda (key _value) (if (string-match "\\`[^/]*\\(/\\).*\\'" key) (let ((host (substring key 0 (match-beginning 1))) (user (substring key (match-end 1)))) (push (concat user "@" host ":") res)))) ange-ftp-passwd-hashtable) (maphash - (lambda (host user) (push (concat host ":") res)) + (lambda (host _user) (push (concat host ":") res)) ange-ftp-user-hashtable) (or res (list nil))))) @@ -1684,7 +1687,7 @@ good, skip, fatal, or unknown." ange-ftp-process-result ange-ftp-process-result-line))))))) -(defun ange-ftp-process-sentinel (proc str) +(defun ange-ftp-process-sentinel (proc _str) "When FTP process changes state, nuke all file-entries in cache." (let ((name (process-name proc))) (when (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)\\*" name) @@ -1733,7 +1736,7 @@ good, skip, fatal, or unknown." (defvar ange-ftp-gwp-running t) (defvar ange-ftp-gwp-status nil) -(defun ange-ftp-gwp-sentinel (proc str) +(defun ange-ftp-gwp-sentinel (_proc _str) (setq ange-ftp-gwp-running nil)) (defun ange-ftp-gwp-filter (proc str) @@ -1873,7 +1876,7 @@ been queued with no result. CONT will still be called, however." (interactive "sHost: ") (if ange-ftp-nslookup-program (let ((default-directory - (if (file-accessible-directory-p default-directory) + (if (ange-ftp-real-file-accessible-directory-p default-directory) default-directory exec-directory)) ;; It would be nice to make process-connection-type nil, @@ -1916,7 +1919,7 @@ on the gateway machine to do the FTP instead." ;; default-directory. (file-name-handler-alist) (default-directory - (if (file-accessible-directory-p default-directory) + (if (ange-ftp-real-file-accessible-directory-p default-directory) default-directory exec-directory)) proc) @@ -2676,7 +2679,7 @@ The main reason for this alist is to deal with file versions in VMS.") (defmacro ange-ftp-parse-filename () ;;Extract the filename from the current line of a dired-like listing. - `(save-match-data + '(save-match-data (let ((eol (progn (end-of-line) (point)))) (beginning-of-line) (if (re-search-forward directory-listing-before-filename-regexp eol t) @@ -2758,7 +2761,7 @@ match subdirectories as well.") (defmacro ange-ftp-dl-parser () ;; Parse the current buffer, which is assumed to be a descriptive ;; listing, and return a hashtable. - `(let ((tbl (make-hash-table :test 'equal))) + '(let ((tbl (make-hash-table :test 'equal))) (while (not (eobp)) (puthash (buffer-substring (point) @@ -2868,7 +2871,6 @@ NO-ERROR, if a listing for DIRECTORY cannot be obtained." ;; 2. The syntax of FILE and DIR make it impossible that FILE could be a valid ;; subdirectory. This is of course an OS dependent judgment. -(defvar dired-local-variables-file) (defmacro ange-ftp-allow-child-lookup (dir file) `(not (let* ((efile ,file) ; expand once. @@ -2877,10 +2879,6 @@ NO-ERROR, if a listing for DIRECTORY cannot be obtained." (host-type (ange-ftp-host-type (car parsed)))) (or - ;; Deal with dired - (and (boundp 'dired-local-variables-file) ; in the dired-x package - (stringp dired-local-variables-file) - (string-equal dired-local-variables-file efile)) ;; No dots in dir names in vms. (and (eq host-type 'vms) (string-match "\\." efile)) @@ -3247,7 +3245,8 @@ system TYPE.") ;; tell the process filter what size the transfer will be. (let ((attr (file-attributes temp))) (if attr - (ange-ftp-set-xfer-size host user (nth 7 attr)))) + (ange-ftp-set-xfer-size host user + (file-attribute-size attr)))) ;; put or append the file. (let ((result (ange-ftp-send-cmd host user @@ -3373,6 +3372,13 @@ system TYPE.") (file-error nil)) (ange-ftp-real-file-symlink-p file))) +(defun ange-ftp-file-regular-p (file) + ;; Reuse Tramp's implementation. + (if (ange-ftp-ftp-name file) + (and (file-exists-p file) + (eq ?- (aref (file-attribute-modes (file-attributes file)) 0))) + (ange-ftp-real-file-regular-p file))) + (defun ange-ftp-file-exists-p (name) (setq name (expand-file-name name)) (if (ange-ftp-ftp-name name) @@ -3404,6 +3410,10 @@ system TYPE.") file-ent)) (ange-ftp-real-file-directory-p name))) +(defun ange-ftp-file-accessible-directory-p (name) + (and (file-directory-p name) + (file-readable-p name))) + (defun ange-ftp-directory-files (directory &optional full match &rest v19-args) (setq directory (expand-file-name directory)) @@ -3441,9 +3451,9 @@ system TYPE.") (let ((part (ange-ftp-get-file-part file)) (files (ange-ftp-get-files (file-name-directory file)))) (if (ange-ftp-hash-entry-exists-p part files) - (let ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (name (nth 2 parsed)) + (let (;; (host (nth 0 parsed)) + ;; (user (nth 1 parsed)) + ;; (name (nth 2 parsed)) (dirp (gethash part files)) (inode (gethash file ange-ftp-inodes-hashtable))) (unless inode @@ -3475,8 +3485,8 @@ system TYPE.") (let ((f1-parsed (ange-ftp-ftp-name f1)) (f2-parsed (ange-ftp-ftp-name f2))) (if (or f1-parsed f2-parsed) - (let ((f1-mt (nth 5 (file-attributes f1))) - (f2-mt (nth 5 (file-attributes f2)))) + (let ((f1-mt (file-attribute-modification-time (file-attributes f1))) + (f2-mt (file-attribute-modification-time (file-attributes f2)))) (cond ((null f1-mt) nil) ((null f2-mt) t) (t (time-less-p f2-mt f1-mt)))) @@ -3776,7 +3786,8 @@ so return the size on the remote host exactly. See RFC 3659." ;; tell the process filter what size the file is. (let ((attr (file-attributes (or temp2 filename)))) (if attr - (ange-ftp-set-xfer-size t-host t-user (nth 7 attr)))) + (ange-ftp-set-xfer-size t-host t-user + (file-attribute-size attr)))) (ange-ftp-send-cmd t-host @@ -3829,7 +3840,7 @@ so return the size on the remote host exactly. See RFC 3659." (ange-ftp-call-cont cont result line))) (defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists - keep-date preserve-uid-gid + keep-date _preserve-uid-gid _preserve-selinux-context) (interactive "fCopy file: \nFCopy %s to file: \np") (ange-ftp-copy-file-internal filename @@ -4385,10 +4396,13 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (put 'directory-files-and-attributes 'ange-ftp 'ange-ftp-directory-files-and-attributes) (put 'file-directory-p 'ange-ftp 'ange-ftp-file-directory-p) +(put 'file-accessible-directory-p 'ange-ftp + 'ange-ftp-file-accessible-directory-p) (put 'file-writable-p 'ange-ftp 'ange-ftp-file-writable-p) (put 'file-readable-p 'ange-ftp 'ange-ftp-file-readable-p) (put 'file-executable-p 'ange-ftp 'ange-ftp-file-executable-p) (put 'file-symlink-p 'ange-ftp 'ange-ftp-file-symlink-p) +(put 'file-regular-p 'ange-ftp 'ange-ftp-file-regular-p) (put 'delete-file 'ange-ftp 'ange-ftp-delete-file) (put 'verify-visited-file-modtime 'ange-ftp 'ange-ftp-verify-visited-file-modtime) @@ -4430,6 +4444,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (put 'process-file 'ange-ftp 'ange-ftp-process-file) (put 'start-file-process 'ange-ftp 'ignore) (put 'shell-command 'ange-ftp 'ange-ftp-shell-command) +(put 'exec-path 'ange-ftp 'ignore) ;;; Define ways of getting at unmodified Emacs primitives, ;;; turning off our handler. @@ -4469,6 +4484,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (ange-ftp-run-real-handler 'directory-files-and-attributes args)) (defun ange-ftp-real-file-directory-p (&rest args) (ange-ftp-run-real-handler 'file-directory-p args)) +(defun ange-ftp-real-file-accessible-directory-p (&rest args) + (ange-ftp-run-real-handler 'file-accessible-directory-p args)) (defun ange-ftp-real-file-writable-p (&rest args) (ange-ftp-run-real-handler 'file-writable-p args)) (defun ange-ftp-real-file-readable-p (&rest args) @@ -4477,6 +4494,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (ange-ftp-run-real-handler 'file-executable-p args)) (defun ange-ftp-real-file-symlink-p (&rest args) (ange-ftp-run-real-handler 'file-symlink-p args)) +(defun ange-ftp-real-file-regular-p (&rest args) + (ange-ftp-run-real-handler 'file-regular-p args)) (defun ange-ftp-real-delete-file (&rest args) (ange-ftp-run-real-handler 'delete-file args)) (defun ange-ftp-real-verify-visited-file-modtime (&rest args) @@ -5199,7 +5218,7 @@ Other orders of $ and _ seem to all work just fine.") ";\\([0-9]+\\)$")) (version 0)) (maphash - (lambda (name val) + (lambda (name _val) (and (string-match regexp name) (setq version (max version diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index a84a7b1c716..bf179c8782a 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -713,8 +713,7 @@ Use variable `browse-url-filename-alist' to map filenames to URLs." (let ((coding (if (equal system-type 'windows-nt) ;; W32 pretends that file names are UTF-8 encoded. 'utf-8 - (and (default-value 'enable-multibyte-characters) - (or file-name-coding-system + (and (or file-name-coding-system default-file-name-coding-system))))) (if coding (setq file (encode-coding-string file coding)))) (setq file (browse-url-url-encode-chars file "[*\"()',=;?% ]")) @@ -1257,18 +1256,16 @@ used instead of `browse-url-new-window-flag'." (defvar url-handler-regexp) ;;;###autoload -(defun browse-url-emacs (url &optional _new-window) - "Ask Emacs to load URL into a buffer and show it in another window." +(defun browse-url-emacs (url &optional same-window) + "Ask Emacs to load URL into a buffer and show it in another window. +Optional argument SAME-WINDOW non-nil means show the URL in the +currently selected window instead." (interactive (browse-url-interactive-arg "URL: ")) (require 'url-handlers) (let ((file-name-handler-alist (cons (cons url-handler-regexp 'url-file-handler) file-name-handler-alist))) - ;; Ignore `new-window': with all other browsers the URL is always shown - ;; in another window than the current Emacs one since it's shown in - ;; another application's window. - ;; (if new-window (find-file-other-window url) (find-file url)) - (find-file-other-window url))) + (if same-window (find-file url) (find-file-other-window url)))) ;;;###autoload (defun browse-url-gnome-moz (url &optional new-window) diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 5f44c360342..4397817032f 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -41,9 +41,16 @@ (defvar dbus-message-type-method-return) (defvar dbus-message-type-error) (defvar dbus-message-type-signal) -(defvar dbus-debug) (defvar dbus-registered-objects-table) +;; The following symbols are defined in dbusbind.c. We need them also +;; when Emacs is compiled without D-Bus support. +(unless (boundp 'dbus-error) + (define-error 'dbus-error "D-Bus error")) + +(unless (boundp 'dbus-debug) + (defvar dbus-debug nil)) + ;; Pacify byte compiler. (eval-when-compile (require 'cl-lib)) diff --git a/lisp/net/dns.el b/lisp/net/dns.el index 057ae3219ee..b3b430d2ba8 100644 --- a/lisp/net/dns.el +++ b/lisp/net/dns.el @@ -117,7 +117,7 @@ updated. Set this variable to t to disable the check.") length) (while (not ended) (setq length (dns-read-bytes 1)) - (if (= 192 (logand length (lsh 3 6))) + (if (= 192 (logand length (ash 3 6))) (let ((offset (+ (* (logand 63 length) 256) (dns-read-bytes 1)))) (save-excursion @@ -144,17 +144,17 @@ If TCP-P, the first two bytes of the package with be the length field." (dns-write-bytes (dns-get 'id spec) 2) (dns-write-bytes (logior - (lsh (if (dns-get 'response-p spec) 1 0) -7) - (lsh + (ash (if (dns-get 'response-p spec) 1 0) 7) + (ash (cond ((eq (dns-get 'opcode spec) 'query) 0) ((eq (dns-get 'opcode spec) 'inverse-query) 1) ((eq (dns-get 'opcode spec) 'status) 2) (t (error "No such opcode: %s" (dns-get 'opcode spec)))) - -3) - (lsh (if (dns-get 'authoritative-p spec) 1 0) -2) - (lsh (if (dns-get 'truncated-p spec) 1 0) -1) - (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0))) + 3) + (ash (if (dns-get 'authoritative-p spec) 1 0) 2) + (ash (if (dns-get 'truncated-p spec) 1 0) 1) + (ash (if (dns-get 'recursion-desired-p spec) 1 0) 0))) (dns-write-bytes (cond ((eq (dns-get 'response-code spec) 'no-error) 0) @@ -198,20 +198,20 @@ If TCP-P, the first two bytes of the package with be the length field." (goto-char (point-min)) (push (list 'id (dns-read-bytes 2)) spec) (let ((byte (dns-read-bytes 1))) - (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t)) + (push (list 'response-p (if (zerop (logand byte (ash 1 7))) nil t)) spec) - (let ((opcode (logand byte (lsh 7 3)))) + (let ((opcode (logand byte (ash 7 3)))) (push (list 'opcode (cond ((eq opcode 0) 'query) ((eq opcode 1) 'inverse-query) ((eq opcode 2) 'status))) spec)) - (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2))) + (push (list 'authoritative-p (if (zerop (logand byte (ash 1 2))) nil t)) spec) - (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t)) + (push (list 'truncated-p (if (zerop (logand byte (ash 1 2))) nil t)) spec) (push (list 'recursion-desired-p - (if (zerop (logand byte (lsh 1 0))) nil t)) spec)) + (if (zerop (logand byte (ash 1 0))) nil t)) spec)) (let ((rc (logand (dns-read-bytes 1) 15))) (push (list 'response-code (cond diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el index 584d1a9d0d8..f63e807b688 100644 --- a/lisp/net/eudc-bob.el +++ b/lisp/net/eudc-bob.el @@ -25,8 +25,15 @@ ;;; Commentary: +;; eudc-bob.el presents binary entries in LDAP results in interactive +;; ways. For example, it will display JPEG binary data as an inline +;; image in the results buffer. See also +;; https://tools.ietf.org/html/rfc2798. + ;;; Usage: -;; See the corresponding info file + +;; The eudc-bob interactive functions are invoked when the user +;; interacts with an `eudc-query-form' results buffer. ;;; Code: @@ -148,40 +155,21 @@ display a button." "Toggle inline display of an image." (interactive) (when (eudc-bob-can-display-inline-images) - (cond ((featurep 'xemacs) - (let ((overlays (append (overlays-at (1- (point))) - (overlays-at (point)))) - overlay glyph) - (setq overlay (car overlays)) - (while (and overlay - (not (setq glyph (overlay-get overlay 'glyph)))) - (setq overlays (cdr overlays)) - (setq overlay (car overlays))) - (if overlay - (if (overlay-get overlay 'end-glyph) - (progn - (overlay-put overlay 'end-glyph nil) - (overlay-put overlay 'invisible nil)) - (overlay-put overlay 'end-glyph glyph) - (overlay-put overlay 'invisible t))))) - (t - (let* ((overlays (append (overlays-at (1- (point))) - (overlays-at (point)))) - image) - - ;; Search overlay with an image. - (while (and overlays (null image)) - (let ((prop (overlay-get (car overlays) 'eudc-image))) - (if (eq 'image (car-safe prop)) - (setq image prop) - (setq overlays (cdr overlays))))) - - ;; Toggle that overlay's image display. - (when overlays - (let ((overlay (car overlays))) - (overlay-put overlay 'display - (if (overlay-get overlay 'display) - nil image))))))))) + (let* ((overlays (append (overlays-at (1- (point))) + (overlays-at (point)))) + image) + ;; Search overlay with an image. + (while (and overlays (null image)) + (let ((prop (overlay-get (car overlays) 'eudc-image))) + (if (eq 'image (car-safe prop)) + (setq image prop) + (setq overlays (cdr overlays))))) + ;; Toggle that overlay's image display. + (when overlays + (let ((overlay (car overlays))) + (overlay-put overlay 'display + (if (overlay-get overlay 'display) + nil image))))))) (defun eudc-bob-display-audio (data) "Display a button for audio DATA." @@ -265,25 +253,19 @@ display a button." (interactive "@e") (run-hooks 'activate-menubar-hook) (eudc-jump-to-event event) - (if (featurep 'xemacs) - (progn - (run-hooks 'activate-popup-menu-hook) - (popup-menu (eudc-bob-menu))) - (let ((result (x-popup-menu t (eudc-bob-menu))) - command) - (if result - (progn - (setq command (lookup-key (eudc-bob-menu) - (apply 'vector result))) - (command-execute command)))))) + (let ((result (x-popup-menu t (eudc-bob-menu))) + command) + (if result + (progn + (setq command (lookup-key (eudc-bob-menu) + (apply 'vector result))) + (command-execute command))))) (setq eudc-bob-generic-keymap (let ((map (make-sparse-keymap))) (define-key map "s" 'eudc-bob-save-object) (define-key map "!" 'eudc-bob-pipe-object-to-external-program) - (define-key map (if (featurep 'xemacs) - [button3] - [down-mouse-3]) 'eudc-bob-popup-menu) + (define-key map [down-mouse-3] 'eudc-bob-popup-menu) map)) (setq eudc-bob-image-keymap @@ -294,25 +276,19 @@ display a button." (setq eudc-bob-sound-keymap (let ((map (make-sparse-keymap))) (define-key map [return] 'eudc-bob-play-sound-at-point) - (define-key map (if (featurep 'xemacs) - [button2] - [down-mouse-2]) 'eudc-bob-play-sound-at-mouse) + (define-key map [down-mouse-2] 'eudc-bob-play-sound-at-mouse) map)) (setq eudc-bob-url-keymap (let ((map (make-sparse-keymap))) (define-key map [return] 'browse-url-at-point) - (define-key map (if (featurep 'xemacs) - [button2] - [down-mouse-2]) 'browse-url-at-mouse) + (define-key map [down-mouse-2] 'browse-url-at-mouse) map)) (setq eudc-bob-mail-keymap (let ((map (make-sparse-keymap))) (define-key map [return] 'goto-address-at-point) - (define-key map (if (featurep 'xemacs) - [button2] - [down-mouse-2]) 'goto-address-at-point) + (define-key map [down-mouse-2] 'goto-address-at-point) map)) (set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap) @@ -320,19 +296,18 @@ display a button." ;; If the first arguments can be nil here, then these 3 can be ;; defconsts once more. -(when (not (featurep 'xemacs)) - (easy-menu-define eudc-bob-generic-menu - eudc-bob-generic-keymap - "" - eudc-bob-generic-menu) - (easy-menu-define eudc-bob-image-menu - eudc-bob-image-keymap - "" - eudc-bob-image-menu) - (easy-menu-define eudc-bob-sound-menu - eudc-bob-sound-keymap - "" - eudc-bob-sound-menu)) +(easy-menu-define eudc-bob-generic-menu + eudc-bob-generic-keymap + "" + eudc-bob-generic-menu) +(easy-menu-define eudc-bob-image-menu + eudc-bob-image-keymap + "" + eudc-bob-image-menu) +(easy-menu-define eudc-bob-sound-menu + eudc-bob-sound-keymap + "" + eudc-bob-sound-menu) ;;;###autoload (defun eudc-display-generic-binary (data) diff --git a/lisp/net/eudc-hotlist.el b/lisp/net/eudc-hotlist.el index a739561c7dc..0762445c237 100644 --- a/lisp/net/eudc-hotlist.el +++ b/lisp/net/eudc-hotlist.el @@ -55,11 +55,6 @@ These are the special commands of this mode: t -- Transpose the server at point and the previous one q -- Commit the changes and quit. x -- Quit without committing the changes." - (when (featurep 'xemacs) - (setq mode-popup-menu eudc-hotlist-menu) - (when (featurep 'menubar) - (set-buffer-menubar current-menubar) - (add-submenu nil (cons "EUDC-Hotlist" (cdr (cdr eudc-hotlist-menu)))))) (setq buffer-read-only t)) ;;;###autoload @@ -179,10 +174,9 @@ These are the special commands of this mode: ["Save and Quit" eudc-hotlist-quit-edit t] ["Exit without Saving" kill-this-buffer t])) -(when (not (featurep 'xemacs)) - (easy-menu-define eudc-hotlist-emacs-menu +(easy-menu-define eudc-hotlist-emacs-menu eudc-hotlist-mode-map "" - eudc-hotlist-menu)) + eudc-hotlist-menu) ;;; eudc-hotlist.el ends here diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 8d1071af727..a28fa6aa17a 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -1,4 +1,4 @@ -;;; eudc.el --- Emacs Unified Directory Client +;;; eudc.el --- Emacs Unified Directory Client -*- lexical-binding:t -*- ;; Copyright (C) 1998-2018 Free Software Foundation, Inc. @@ -47,7 +47,7 @@ (require 'wid-edit) -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) (eval-and-compile (if (not (fboundp 'make-overlay)) @@ -68,6 +68,7 @@ (defvar eudc-mode-map (let ((map (make-sparse-keymap))) + (set-keymap-parent map widget-keymap) (define-key map "q" 'kill-current-buffer) (define-key map "x" 'kill-current-buffer) (define-key map "f" 'eudc-query-form) @@ -75,7 +76,6 @@ (define-key map "n" 'eudc-move-to-next-record) (define-key map "p" 'eudc-move-to-previous-record) map)) -(set-keymap-parent eudc-mode-map widget-keymap) (defvar mode-popup-menu) @@ -158,25 +158,6 @@ properties on the list." (setq plist (cdr (cdr plist)))) default)) -(if (not (fboundp 'split-string)) - (defun split-string (string &optional pattern) - "Return a list of substrings of STRING which are separated by PATTERN. -If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." - (or pattern - (setq pattern "[ \f\t\n\r\v]+")) - (let (parts (start 0)) - (when (string-match pattern string 0) - (if (> (match-beginning 0) 0) - (setq parts (cons (substring string 0 (match-beginning 0)) nil))) - (setq start (match-end 0)) - (while (and (string-match pattern string start) - (> (match-end 0) start)) - (setq parts (cons (substring string start (match-beginning 0)) parts) - start (match-end 0)))) - (nreverse (if (< start (length string)) - (cons (substring string start) parts) - parts))))) - (defun eudc-replace-in-string (str regexp newtext) "Replace all matches in STR for REGEXP with NEWTEXT. Value is the new string." @@ -314,7 +295,7 @@ accordingly. Otherwise it is set to its EUDC default binding" (defun eudc-update-local-variables () "Update all EUDC variables according to their local settings." (interactive) - (mapcar 'eudc-update-variable eudc-local-vars)) + (mapcar #'eudc-update-variable eudc-local-vars)) (eudc-default-set 'eudc-query-function nil) (eudc-default-set 'eudc-list-attributes-function nil) @@ -378,7 +359,7 @@ BEG and END delimit the text which is to be replaced." (let ((replacement)) (setq replacement (completing-read "Multiple matches found; choose one: " - (mapcar 'list choices))) + (mapcar #'list choices))) (delete-region beg end) (insert replacement))) @@ -415,7 +396,7 @@ underscore characters are replaced by spaces." (if match (cdr match) (capitalize - (mapconcat 'identity + (mapconcat #'identity (split-string (symbol-name attribute) "_") " "))))) @@ -432,7 +413,7 @@ if any, is called to print the value in cdr of FIELD." (progn (eval (list (cdr match) val)) (insert "\n")) - (mapcar + (mapc (function (lambda (val-elem) (indent-to col) @@ -598,9 +579,10 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'." (setq result (eudc-add-field-to-records (cons (car field) (mapconcat - 'identity + #'identity (cdr field) - "\n")) result))) + "\n")) + result))) ((eq 'duplicate method) (setq result (eudc-distribute-field-on-records field result))))))) @@ -613,12 +595,9 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'." (mapcar (function (lambda (rec) - (if (eval (cons 'and - (mapcar - (function - (lambda (attr) - (consp (assq attr rec)))) - attrs))) + (if (cl-every (lambda (attr) + (consp (assq attr rec))) + attrs) rec))) records))) @@ -632,25 +611,14 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'." (defun eudc-distribute-field-on-records (field records) "Duplicate each individual record in RECORDS according to value of FIELD. Each copy is added a new field containing one of the values of FIELD." - (let (result - (values (cdr field))) - ;; Uniquify values first - (while values - (setcdr values (delete (car values) (cdr values))) - (setq values (cdr values))) - (mapc - (function - (lambda (value) - (let ((result-list (copy-sequence records))) - (setq result-list (eudc-add-field-to-records - (cons (car field) value) - result-list)) - (setq result (append result-list result)) - ))) - (cdr field)) + (let (result) + (dolist (value (delete-dups (cdr field))) ;; Uniquify values first. + (setq result (nconc (eudc-add-field-to-records + (cons (car field) value) + records) + result))) result)) - (define-derived-mode eudc-mode special-mode "EUDC" "Major mode used in buffers displaying the results of directory queries. There is no sense in calling this command from a buffer other than @@ -662,9 +630,7 @@ These are the special commands of EUDC mode: n -- Move to next record. p -- Move to previous record. b -- Insert record at point into the BBDB database." - (if (not (featurep 'xemacs)) - (easy-menu-define eudc-emacs-menu eudc-mode-map "" (eudc-menu)) - (setq mode-popup-menu (eudc-menu)))) + (easy-menu-define eudc-emacs-menu eudc-mode-map "" (eudc-menu))) ;;}}} @@ -776,8 +742,8 @@ otherwise a list of symbols is returned." (setq query-alist (cdr query-alist))) query) (if eudc-protocol-has-default-query-attributes - (mapconcat 'identity words " ") - (list (cons 'name (mapconcat 'identity words " "))))))) + (mapconcat #'identity words " ") + (list (cons 'name (mapconcat #'identity words " "))))))) (defun eudc-extract-n-word-formats (format-list n) "Extract a list of N-long formats from FORMAT-LIST. @@ -836,7 +802,6 @@ see `eudc-inline-expansion-servers'" "[ \t]+")) query-formats response - response-string response-strings (eudc-former-server eudc-server) (eudc-former-protocol eudc-protocol) @@ -894,20 +859,18 @@ see `eudc-inline-expansion-servers'" (error "No match") ;; Process response through eudc-inline-expansion-format - (while response - (setq response-string - (apply 'format - (car eudc-inline-expansion-format) - (mapcar (function - (lambda (field) - (or (cdr (assq field (car response))) - ""))) - (eudc-translate-attribute-list - (cdr eudc-inline-expansion-format))))) - (if (> (length response-string) 0) - (setq response-strings - (cons response-string response-strings))) - (setq response (cdr response))) + (dolist (r response) + (let ((response-string + (apply #'format + (car eudc-inline-expansion-format) + (mapcar (function + (lambda (field) + (or (cdr (assq field r)) + ""))) + (eudc-translate-attribute-list + (cdr eudc-inline-expansion-format)))))) + (if (> (length response-string) 0) + (push response-string response-strings)))) (if (or (and replace (not eudc-expansion-overwrites-query)) @@ -923,7 +886,7 @@ see `eudc-inline-expansion-servers'" (eudc-select response-strings beg end)) ((eq eudc-multiple-match-handling-method 'all) (delete-region beg end) - (insert (mapconcat 'identity response-strings ", "))) + (insert (mapconcat #'identity response-strings ", "))) ((eq eudc-multiple-match-handling-method 'abort) (error "There is more than one match for the query"))))) (or (and (equal eudc-server eudc-former-server) @@ -943,10 +906,9 @@ queries the server for the existing fields and displays a corresponding form." prompts widget (width 0) - inhibit-read-only pt) (switch-to-buffer buffer) - (setq inhibit-read-only t) + (let ((inhibit-read-only t)) (erase-buffer) (kill-all-local-variables) (make-local-variable 'eudc-form-widget-list) @@ -960,11 +922,10 @@ queries the server for the existing fields and displays a corresponding form." (widget-insert "Protocol : " (symbol-name eudc-protocol) "\n") ;; Build the list of prompts (setq prompts (if eudc-use-raw-directory-names - (mapcar 'symbol-name (eudc-translate-attribute-list fields)) + (mapcar #'symbol-name (eudc-translate-attribute-list fields)) (mapcar (function (lambda (field) - (or (and (assq field eudc-user-attribute-names-alist) - (cdr (assq field eudc-user-attribute-names-alist))) + (or (cdr (assq field eudc-user-attribute-names-alist)) (capitalize (symbol-name field))))) fields))) ;; Loop over prompt strings to find the longest one @@ -1008,7 +969,7 @@ queries the server for the existing fields and displays a corresponding form." "Quit") (goto-char pt) (use-local-map widget-keymap) - (widget-setup)) + (widget-setup))) ) (defun eudc-bookmark-server (server protocol) @@ -1177,60 +1138,41 @@ queries the server for the existing fields and displays a corresponding form." eudc-tail-menu))) (defun eudc-install-menu () - (cond - ((and (featurep 'xemacs) (featurep 'menubar)) - (add-submenu '("Tools") (eudc-menu))) - ((not (featurep 'xemacs)) - (cond - ((fboundp 'easy-menu-create-menu) - (define-key - global-map - [menu-bar tools directory-search] - (cons "Directory Servers" - (easy-menu-create-menu "Directory Servers" (cdr (eudc-menu)))))) - ((fboundp 'easy-menu-add-item) - (let ((menu (eudc-menu))) - (easy-menu-add-item nil '("tools") (easy-menu-create-menu (car menu) - (cdr menu))))) - ((fboundp 'easy-menu-create-keymaps) - (easy-menu-define eudc-menu-map eudc-mode-map "Directory Client Menu" (eudc-menu)) - (define-key - global-map - [menu-bar tools eudc] - (cons "Directory Servers" - (easy-menu-create-keymaps "Directory Servers" - (cdr (eudc-menu)))))) - (t - (error "Unknown version of easymenu")))) - )) - + (define-key + global-map + [menu-bar tools directory-search] + (cons "Directory Servers" + (easy-menu-create-menu "Directory Servers" (cdr (eudc-menu)))))) ;;; Load time initializations : -;;; Load the options file +;; Load the options file (if (and (not noninteractive) (and (locate-library eudc-options-file) (progn (message "") t)) ; Remove mode line message (not (featurep 'eudc-options-file))) (load eudc-options-file)) -;;; Install the full menu +;; Install the full menu (unless (featurep 'infodock) (eudc-install-menu)) -;;; The following installs a short menu for EUDC at XEmacs startup. +;; The following installs a short menu for EUDC at Emacs startup. ;;;###autoload (defun eudc-load-eudc () "Load the Emacs Unified Directory Client. This does nothing except loading eudc by autoload side-effect." (interactive) + ;; FIXME: By convention, loading a file should "do nothing significant" + ;; since Emacs may occasionally load a file for "frivolous" reasons + ;; (e.g. to find a docstring), so having a function which just loads + ;; the file doesn't seem very useful. nil) ;;;###autoload -(cond - ((not (featurep 'xemacs)) +(progn (defvar eudc-tools-menu (let ((map (make-sparse-keymap "Directory Servers"))) (define-key map [phone] @@ -1255,34 +1197,6 @@ This does nothing except loading eudc by autoload side-effect." :help ,(purecopy "Load the Emacs Unified Directory Client"))) map)) (fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu))) - (t - (let ((menu '("Directory Servers" - ["Load Hotlist of Servers" eudc-load-eudc t] - ["New Server" eudc-set-server t] - ["---" nil nil] - ["Query with Form" eudc-query-form t] - ["Expand Inline Query" eudc-expand-inline t] - ["---" nil nil] - ["Get Email" eudc-get-email t] - ["Get Phone" eudc-get-phone t]))) - (if (not (featurep 'eudc-autoloads)) - (if (featurep 'xemacs) - (if (and (featurep 'menubar) - (not (featurep 'infodock))) - (add-submenu '("Tools") menu)) - (require 'easymenu) - (cond - ((fboundp 'easy-menu-add-item) - (easy-menu-add-item nil '("tools") - (easy-menu-create-menu (car menu) - (cdr menu)))) - ((fboundp 'easy-menu-create-keymaps) - (define-key - global-map - [menu-bar tools eudc] - (cons "Directory Servers" - (easy-menu-create-keymaps "Directory Servers" - (cdr menu))))))))))) ;;}}} diff --git a/lisp/net/eudcb-bbdb.el b/lisp/net/eudcb-bbdb.el index fb618d12098..ac4814a25cb 100644 --- a/lisp/net/eudcb-bbdb.el +++ b/lisp/net/eudcb-bbdb.el @@ -47,10 +47,13 @@ BBDB < 3 used `net'; BBDB >= 3 uses `mail'." ;; This just-in-time translation permits upgrading from BBDB 2 to ;; BBDB 3 without restarting Emacs. - (if (and (eq field-symbol 'net) - (eudc--using-bbdb-3-or-newer-p)) - 'mail - field-symbol)) + (cond ((and (eq field-symbol 'net) + (eudc--using-bbdb-3-or-newer-p)) + 'mail) + ((and (eq field-symbol 'company) + (eudc--using-bbdb-3-or-newer-p)) + 'organization) + (t field-symbol))) (defvar eudc-bbdb-attributes-translation-alist '((name . lastname) @@ -124,18 +127,31 @@ BBDB < 3 used `net'; BBDB >= 3 uses `mail'." (declare-function bbdb-record-addresses "ext:bbdb" t) ; via bbdb-defstruct (declare-function bbdb-records "ext:bbdb" (&optional dont-check-disk already-in-db-buffer)) +(declare-function bbdb-record-notes "ext:bbdb" t) ; via bbdb-defstruct + +;; External, BBDB >= 3. +(declare-function bbdb-phone-label "ext:bbdb" t) ; via bbdb-defstruct +(declare-function bbdb-record-phone "ext:bbdb" t) ; via bbdb-defstruct +(declare-function bbdb-record-address "ext:bbdb" t) ; via bbdb-defstruct +(declare-function bbdb-record-xfield "ext:bbdb" t) ; via bbdb-defstruct (defun eudc-bbdb-extract-phones (record) (require 'bbdb) (mapcar (function (lambda (phone) (if eudc-bbdb-use-locations-as-attribute-names - (cons (intern (bbdb-phone-location phone)) + (cons (intern (if (eudc--using-bbdb-3-or-newer-p) + (bbdb-phone-label phone) + (bbdb-phone-location phone))) (bbdb-phone-string phone)) (cons 'phones (format "%s: %s" - (bbdb-phone-location phone) + (if (eudc--using-bbdb-3-or-newer-p) + (bbdb-phone-label phone) + (bbdb-phone-location phone)) (bbdb-phone-string phone)))))) - (bbdb-record-phones record))) + (if (eudc--using-bbdb-3-or-newer-p) + (bbdb-record-phone record) + (bbdb-record-phones record)))) (defun eudc-bbdb-extract-addresses (record) (require 'bbdb) @@ -157,7 +173,9 @@ BBDB < 3 used `net'; BBDB >= 3 uses `mail'." (cons (intern (bbdb-address-location address)) val) (cons 'addresses (concat (bbdb-address-location address) "\n" val)))) - (bbdb-record-addresses record)))) + (if (eudc--using-bbdb-3-or-newer-p) + (bbdb-record-address record) + (bbdb-record-addresses record))))) (defun eudc-bbdb-format-record-as-result (record) "Format the BBDB RECORD as a EUDC query result record. @@ -176,7 +194,11 @@ The record is filtered according to `eudc-bbdb-current-return-attributes'" (setq val (eudc-bbdb-extract-phones record))) ((eq attr 'addresses) (setq val (eudc-bbdb-extract-addresses record))) - ((memq attr '(firstname lastname aka company net notes)) + ((eq attr 'notes) + (if (eudc--using-bbdb-3-or-newer-p) + (setq val (bbdb-record-xfield record 'notes)) + (setq val (bbdb-record-notes record)))) + ((memq attr '(firstname lastname aka company net)) (setq val (eval (list (intern (concat "bbdb-record-" diff --git a/lisp/net/eudcb-mab.el b/lisp/net/eudcb-mab.el index a21348480e0..4d517c19954 100644 --- a/lisp/net/eudcb-mab.el +++ b/lisp/net/eudcb-mab.el @@ -53,15 +53,15 @@ RETURN-ATTRS is a list of attributes to return, defaulting to (let ((fmt-string "%ln:%fn:%p:%e") (mab-buffer (get-buffer-create " *mab contacts*")) - (modified (nth 5 (file-attributes eudc-contacts-file))) + (modified (file-attribute-modification-time + (file-attributes eudc-contacts-file))) result) (with-current-buffer mab-buffer (make-local-variable 'eudc-buffer-time) (goto-char (point-min)) (when (or (eobp) (time-less-p eudc-buffer-time modified)) (erase-buffer) - (call-process (executable-find "contacts") nil t nil - "-H" "-l" "-f" fmt-string) + (call-process "contacts" nil t nil "-H" "-l" "-f" fmt-string) (setq eudc-buffer-time modified)) (goto-char (point-min)) (while (not (eobp)) diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 66b1767b563..64cc1a51f69 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -186,17 +186,17 @@ See also `eww-form-checkbox-selected-symbol'." :group 'eww) (defface eww-form-text - '((t (:background "#505050" - :foreground "white" - :box (:line-width 1)))) + '((t :background "#505050" + :foreground "white" + :box (:line-width 1))) "Face for eww text inputs." :version "24.4" :group 'eww) (defface eww-form-textarea - '((t (:background "#C0C0C0" - :foreground "black" - :box (:line-width 1)))) + '((t :background "#C0C0C0" + :foreground "black" + :box (:line-width 1))) "Face for eww textarea inputs." :version "24.4" :group 'eww) @@ -218,11 +218,17 @@ See also `eww-form-checkbox-selected-symbol'." (defvar eww-data nil) (defvar eww-history nil) (defvar eww-history-position 0) +(defvar eww-prompt-history nil) (defvar eww-local-regex "localhost" "When this regex is found in the URL, it's not a keyword but an address.") (defvar eww-link-keymap + (let ((map (copy-keymap shr-map))) + (define-key map "\r" 'eww-follow-link) + map)) + +(defvar eww-image-link-keymap (let ((map (copy-keymap shr-image-map))) (define-key map "\r" 'eww-follow-link) map)) @@ -250,7 +256,7 @@ word(s) will be searched for via `eww-search-prefix'." (prompt (concat "Enter URL or keywords" (if uris (format " (default %s)" (car uris)) "") ": "))) - (list (read-string prompt nil nil uris)))) + (list (read-string prompt nil 'eww-prompt-history uris)))) (setq url (eww--dwim-expand-url url)) (pop-to-buffer-same-window (if (eq major-mode 'eww-mode) @@ -263,8 +269,13 @@ word(s) will be searched for via `eww-search-prefix'." (let ((parsed (url-generic-parse-url url))) (when (url-host parsed) (unless (puny-highly-restrictive-domain-p (url-host parsed)) - (setf (url-host parsed) (puny-encode-domain (url-host parsed))) - (setq url (url-recreate-url parsed))))) + (setf (url-host parsed) (puny-encode-domain (url-host parsed))))) + ;; When the URL is on the form "http://a/../../../g", chop off all + ;; the leading "/.."s. + (when (url-filename parsed) + (while (string-match "\\`/[.][.]/" (url-filename parsed)) + (setf (url-filename parsed) (substring (url-filename parsed) 3)))) + (setq url (url-recreate-url parsed))) (plist-put eww-data :url url) (plist-put eww-data :title "") (eww-update-header-line-format) @@ -272,7 +283,7 @@ word(s) will be searched for via `eww-search-prefix'." (insert (format "Loading %s..." url)) (goto-char (point-min))) (url-retrieve url 'eww-render - (list url nil (current-buffer)))) + (list url nil (current-buffer)))) (defun eww--dwim-expand-url (url) (setq url (string-trim url)) @@ -349,9 +360,6 @@ Currently this means either text/html or application/xhtml+xml." "application/xhtml+xml"))) (defun eww-render (status url &optional point buffer encode) - (let ((redirect (plist-get status :redirect))) - (when redirect - (setq url redirect))) (let* ((headers (eww-parse-headers)) (content-type (mail-header-parse-content-type @@ -364,12 +372,19 @@ Currently this means either text/html or application/xhtml+xml." (eww-detect-charset (eww-html-p (car content-type))) "utf-8")))) (data-buffer (current-buffer)) + (shr-target-id (url-target (url-generic-parse-url url))) last-coding-system-used) + (let ((redirect (plist-get status :redirect))) + (when redirect + (setq url redirect))) (with-current-buffer buffer ;; Save the https peer status. (plist-put eww-data :peer (plist-get status :peer)) ;; Make buffer listings more informative. - (setq list-buffers-directory url)) + (setq list-buffers-directory url) + ;; Let the URL library have a handle to the current URL for + ;; referer purposes. + (setq url-current-lastloc (url-generic-parse-url url))) (unwind-protect (progn (cond @@ -460,7 +475,6 @@ Currently this means either text/html or application/xhtml+xml." (plist-put eww-data :dom document) (let ((inhibit-read-only t) (inhibit-modification-hooks t) - (shr-target-id (url-target (url-generic-parse-url url))) (shr-external-rendering-functions (append shr-external-rendering-functions @@ -547,7 +561,11 @@ Currently this means either text/html or application/xhtml+xml." (eww-handle-link dom) (let ((start (point))) (shr-tag-a dom) - (put-text-property start (point) 'keymap eww-link-keymap))) + (put-text-property start (point) + 'keymap + (if (mm-images-in-region-p start (point)) + eww-image-link-keymap + eww-link-keymap)))) (defun eww-update-header-line-format () (setq header-line-format @@ -731,7 +749,10 @@ the like." most-negative-fixnum) (or (dom-attr result :eww-readability-score) most-negative-fixnum)) - (setq result highest))) + ;; We set a lower bound to how long we accept that the + ;; readable portion of the page is going to be. + (when (> (length (split-string (dom-texts highest))) 100) + (setq result highest)))) result)) (defvar eww-mode-map @@ -1236,14 +1257,8 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") :eww-form eww-form)) (options nil) (start (point)) - (max 0) - opelem) - (if (eq (dom-tag dom) 'optgroup) - (dolist (groupelem (dom-children dom)) - (unless (dom-attr groupelem 'disabled) - (setq opelem (append opelem (list groupelem))))) - (setq opelem (list dom))) - (dolist (elem opelem) + (max 0)) + (dolist (elem (dom-non-text-children dom)) (when (eq (dom-tag elem) 'option) (when (dom-attr elem 'selected) (nconc menu (list :value (dom-attr elem 'value)))) @@ -1489,7 +1504,8 @@ If EXTERNAL is double prefix, browse in new buffer." ((string-match "^mailto:" url) (browse-url-mail url)) ((and (consp external) (<= (car external) 4)) - (funcall shr-external-browser url)) + (funcall shr-external-browser url) + (shr--blink-link)) ;; This is a #target url in the same page as the current one. ((and (url-target (url-generic-parse-url url)) (eww-same-page-p url (plist-get eww-data :url))) @@ -1651,7 +1667,7 @@ If CHARSET is nil then use UTF-8." (defun eww-read-bookmarks () (let ((file (expand-file-name "eww-bookmarks" eww-bookmarks-directory))) (setq eww-bookmarks - (unless (zerop (or (nth 7 (file-attributes file)) 0)) + (unless (zerop (or (file-attribute-size (file-attributes file)) 0)) (with-temp-buffer (insert-file-contents file) (read (current-buffer))))))) @@ -1797,13 +1813,9 @@ If CHARSET is nil then use UTF-8." (defun eww-save-history () (plist-put eww-data :point (point)) (plist-put eww-data :text (buffer-string)) - (push eww-data eww-history) - (setq eww-data (list :title "")) - ;; Don't let the history grow infinitely. We store quite a lot of - ;; data per page. - (when-let* ((tail (and eww-history-limit - (nthcdr eww-history-limit eww-history)))) - (setcdr tail nil))) + (let ((history-delete-duplicates nil)) + (add-to-history 'eww-history eww-data eww-history-limit t)) + (setq eww-data (list :title ""))) (defvar eww-current-buffer) diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index 35fe680592a..315932b7e69 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -36,6 +36,7 @@ ;;; Code: (require 'cl-lib) +(require 'puny) (defgroup gnutls nil "Emacs interface to the GnuTLS library." @@ -69,9 +70,9 @@ If the value is a list, it should have the form ((HOST-REGEX FLAGS...) (HOST-REGEX FLAGS...) ...) where each HOST-REGEX is a regular expression to be matched -against the hostname, and FLAGS is either t or a list of -one or more verification flags. The supported flags and the -corresponding conditions to be tested are: +against the hostname, on a first-match basis, and FLAGS is either +t or a list of one or more verification flags. The supported +flags and the corresponding conditions to be tested are: :trustfiles -- certificate must be issued by a trusted authority. :hostname -- hostname must match presented certificate's host name. @@ -175,12 +176,12 @@ trust and key files, and priority string." (cons 'gnutls-x509pki (gnutls-boot-parameters :type 'gnutls-x509pki - :hostname host)))))) + :hostname (puny-encode-domain host))))))) (if nowait process (gnutls-negotiate :process process :type 'gnutls-x509pki - :hostname host)))) + :hostname (puny-encode-domain host))))) (define-error 'gnutls-error "GnuTLS error") @@ -303,13 +304,9 @@ defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT." t) ;; if a list, look for hostname matches ((listp gnutls-verify-error) - (apply 'append - (mapcar - (lambda (check) - (when (string-match (nth 0 check) - hostname) - (nth 1 check))) - gnutls-verify-error))) + (cadr (cl-find-if #'(lambda (x) + (string-match (car x) hostname)) + gnutls-verify-error))) ;; else it's nil (t nil)))) (min-prime-bits (or min-prime-bits gnutls-min-prime-bits))) diff --git a/lisp/net/goto-addr.el b/lisp/net/goto-addr.el index ed615d10eb6..db59df374b1 100644 --- a/lisp/net/goto-addr.el +++ b/lisp/net/goto-addr.el @@ -221,10 +221,6 @@ and `goto-address-fontify-p'." ;; snarfed from browse-url.el ;;;###autoload -(define-obsolete-function-alias - 'goto-address-at-mouse 'goto-address-at-point "22.1") - -;;;###autoload (defun goto-address-at-point (&optional event) "Send to the e-mail address or load the URL at point. Send mail to address at point. See documentation for @@ -274,10 +270,7 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and ;;;###autoload (define-minor-mode goto-address-mode - "Minor mode to buttonize URLs and e-mail addresses in the current buffer. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "Minor mode to buttonize URLs and e-mail addresses in the current buffer." nil "" nil diff --git a/lisp/net/hmac-def.el b/lisp/net/hmac-def.el index f493d2d1691..d087d55c56f 100644 --- a/lisp/net/hmac-def.el +++ b/lisp/net/hmac-def.el @@ -73,7 +73,7 @@ If BIT is non-nil, truncate output to specified bits." ,(if (and bit (< (/ bit 8) L)) `(substring key-xor-opad 0 ,(/ bit 8)) ;; return a copy of `key-xor-opad'. - `(concat key-xor-opad))) + '(concat key-xor-opad))) ;; cleanup. (fillarray key-xor-ipad 0) (fillarray key-xor-opad 0))))) diff --git a/lisp/net/imap.el b/lisp/net/imap.el index 3d2a4f948bc..042b0f9a2c9 100644 --- a/lisp/net/imap.el +++ b/lisp/net/imap.el @@ -1,4 +1,4 @@ -;;; imap.el --- imap library +;;; imap.el --- imap library -*- lexical-binding:t -*- ;; Copyright (C) 1998-2018 Free Software Foundation, Inc. @@ -135,20 +135,16 @@ ;;; Code: -(eval-when-compile (require 'cl)) -(eval-and-compile - ;; For Emacs <22.2 and XEmacs. - (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r))) - (autoload 'sasl-find-mechanism "sasl") - (autoload 'digest-md5-parse-digest-challenge "digest-md5") - (autoload 'digest-md5-digest-response "digest-md5") - (autoload 'digest-md5-digest-uri "digest-md5") - (autoload 'digest-md5-challenge "digest-md5") - (autoload 'rfc2104-hash "rfc2104") - (autoload 'utf7-encode "utf7") - (autoload 'utf7-decode "utf7") - (autoload 'format-spec "format-spec") - (autoload 'format-spec-make "format-spec")) +(eval-when-compile (require 'cl-lib)) +(require 'format-spec) +(require 'utf7) +(require 'rfc2104) +;; Hmm... digest-md5 is not part of Emacs. +;; FIXME: Should/can we use sasl-digest.el instead? +(declare-function digest-md5-parse-digest-challenge "ext:digest-md5") +(declare-function digest-md5-digest-response "ext:digest-md5") +(declare-function digest-md5-digest-uri "ext:digest-md5") +(declare-function digest-md5-challenge "ext:digest-md5") ;; User variables. @@ -1700,18 +1696,6 @@ MAILBOX specifies a mailbox on the server in BUFFER." (concat "UID STORE " articles " +FLAGS" (if silent ".SILENT") " (" flags ")")))))) -;; Cf. http://thread.gmane.org/gmane.emacs.gnus.general/65317/focus=65343 -;; Signal an error if we'd get an integer overflow. -;; -;; FIXME: Identify relevant calls to `string-to-number' and replace them with -;; `imap-string-to-integer'. -(defun imap-string-to-integer (string &optional base) - (let ((number (string-to-number string base))) - (if (> number most-positive-fixnum) - (error - (format "String %s cannot be converted to a Lisp integer" number)) - number))) - (defun imap-fetch-safe (uids props &optional receive nouidfetch buffer) "Like `imap-fetch', but DTRT with Exchange 2007 bug. However, UIDS here is a cons, where the car is the canonical form @@ -1900,9 +1884,7 @@ on failure." (setq cmdstr nil) (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) (setq command nil) ;; abort command if no cont-req - (let ((process imap-process) - (stream imap-stream) - (eol imap-client-eol)) + (let ((process imap-process)) (with-current-buffer cmd (imap-log cmd) (process-send-region process (point-min) @@ -1956,7 +1938,7 @@ on failure." 'INCOMPLETE 'OK)))))) -(defun imap-sentinel (process string) +(defun imap-sentinel (process _string) (delete-process process)) (defun imap-find-next-line () @@ -2145,7 +2127,7 @@ Return nil if no complete line has arrived." (imap-forward) (nreverse addresses))) ;; With assert, the code might not be eval'd. - ;; (assert (imap-parse-nil) t "In imap-parse-address-list") + ;; (cl-assert (imap-parse-nil) t "In imap-parse-address-list") (imap-parse-nil))) ;; mailbox = "INBOX" / astring @@ -2218,72 +2200,72 @@ Return nil if no complete line has arrived." (defun imap-parse-response () "Parse an IMAP command response." (let (token) - (case (setq token (read (current-buffer))) - (+ (setq imap-continuation - (or (buffer-substring (min (point-max) (1+ (point))) - (point-max)) - t))) - (* (case (prog1 (setq token (read (current-buffer))) - (imap-forward)) - (OK (imap-parse-resp-text)) - (NO (imap-parse-resp-text)) - (BAD (imap-parse-resp-text)) - (BYE (imap-parse-resp-text)) - (FLAGS (imap-mailbox-put 'flags (imap-parse-flag-list))) - (LIST (imap-parse-data-list 'list)) - (LSUB (imap-parse-data-list 'lsub)) - (SEARCH (imap-mailbox-put - 'search - (read (concat "(" (buffer-substring (point) (point-max)) ")")))) - (STATUS (imap-parse-status)) - (CAPABILITY (setq imap-capability + (pcase (setq token (read (current-buffer))) + ('+ (setq imap-continuation + (or (buffer-substring (min (point-max) (1+ (point))) + (point-max)) + t))) + ('* (pcase (prog1 (setq token (read (current-buffer))) + (imap-forward)) + ('OK (imap-parse-resp-text)) + ('NO (imap-parse-resp-text)) + ('BAD (imap-parse-resp-text)) + ('BYE (imap-parse-resp-text)) + ('FLAGS (imap-mailbox-put 'flags (imap-parse-flag-list))) + ('LIST (imap-parse-data-list 'list)) + ('LSUB (imap-parse-data-list 'lsub)) + ('SEARCH (imap-mailbox-put + 'search + (read (concat "(" (buffer-substring (point) (point-max)) ")")))) + ('STATUS (imap-parse-status)) + ('CAPABILITY (setq imap-capability (read (concat "(" (upcase (buffer-substring (point) (point-max))) ")")))) - (ID (setq imap-id (read (buffer-substring (point) - (point-max))))) - (ACL (imap-parse-acl)) - (t (case (prog1 (read (current-buffer)) - (imap-forward)) - (EXISTS (imap-mailbox-put 'exists token)) - (RECENT (imap-mailbox-put 'recent token)) - (EXPUNGE t) - (FETCH (imap-parse-fetch token)) - (t (message "Garbage: %s" (buffer-string))))))) - (t (let (status) + ('ID (setq imap-id (read (buffer-substring (point) + (point-max))))) + ('ACL (imap-parse-acl)) + (_ (pcase (prog1 (read (current-buffer)) + (imap-forward)) + ('EXISTS (imap-mailbox-put 'exists token)) + ('RECENT (imap-mailbox-put 'recent token)) + ('EXPUNGE t) + ('FETCH (imap-parse-fetch)) + (_ (message "Garbage: %s" (buffer-string))))))) + (_ (let (status) (if (not (integerp token)) (message "Garbage: %s" (buffer-string)) - (case (prog1 (setq status (read (current-buffer))) - (imap-forward)) - (OK (progn - (setq imap-reached-tag (max imap-reached-tag token)) - (imap-parse-resp-text))) - (NO (progn - (setq imap-reached-tag (max imap-reached-tag token)) - (save-excursion - (imap-parse-resp-text)) - (let (code text) - (when (eq (char-after) ?\[) - (setq code (buffer-substring (point) - (search-forward "]"))) - (imap-forward)) - (setq text (buffer-substring (point) (point-max))) - (push (list token status code text) - imap-failed-tags)))) - (BAD (progn - (setq imap-reached-tag (max imap-reached-tag token)) - (save-excursion - (imap-parse-resp-text)) - (let (code text) - (when (eq (char-after) ?\[) - (setq code (buffer-substring (point) - (search-forward "]"))) - (imap-forward)) - (setq text (buffer-substring (point) (point-max))) - (push (list token status code text) imap-failed-tags) - (error "Internal error, tag %s status %s code %s text %s" - token status code text)))) - (t (message "Garbage: %s" (buffer-string)))) + (pcase (prog1 (setq status (read (current-buffer))) + (imap-forward)) + ('OK (progn + (setq imap-reached-tag (max imap-reached-tag token)) + (imap-parse-resp-text))) + ('NO (progn + (setq imap-reached-tag (max imap-reached-tag token)) + (save-excursion + (imap-parse-resp-text)) + (let (code text) + (when (eq (char-after) ?\[) + (setq code (buffer-substring (point) + (search-forward "]"))) + (imap-forward)) + (setq text (buffer-substring (point) (point-max))) + (push (list token status code text) + imap-failed-tags)))) + ('BAD (progn + (setq imap-reached-tag (max imap-reached-tag token)) + (save-excursion + (imap-parse-resp-text)) + (let (code text) + (when (eq (char-after) ?\[) + (setq code (buffer-substring (point) + (search-forward "]"))) + (imap-forward)) + (setq text (buffer-substring (point) (point-max))) + (push (list token status code text) imap-failed-tags) + (error "Internal error, tag %s status %s code %s text %s" + token status code text)))) + (_ (message "Garbage: %s" (buffer-string)))) (when (assq token imap-callbacks) (funcall (cdr (assq token imap-callbacks)) token status) (setq imap-callbacks @@ -2459,7 +2441,7 @@ Return nil if no complete line has arrived." (search-forward "]" nil t)) section))) -(defun imap-parse-fetch (response) +(defun imap-parse-fetch () (when (eq (char-after) ?\() (let (uid flags envelope internaldate rfc822 rfc822header rfc822text rfc822size body bodydetail bodystructure flags-empty) @@ -2593,7 +2575,7 @@ Return nil if no complete line has arrived." (defun imap-parse-flag-list () (let (flag-list start) - (assert (eq (char-after) ?\() nil "In imap-parse-flag-list 1") + (cl-assert (eq (char-after) ?\() nil "In imap-parse-flag-list 1") (while (and (not (eq (char-after) ?\))) (setq start (progn (imap-forward) @@ -2602,7 +2584,7 @@ Return nil if no complete line has arrived." (point))) (> (skip-chars-forward "^ )" (point-at-eol)) 0)) (push (buffer-substring start (point)) flag-list)) - (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list 2") + (cl-assert (eq (char-after) ?\)) nil "In imap-parse-flag-list 2") (imap-forward) (nreverse flag-list))) @@ -2687,7 +2669,7 @@ Return nil if no complete line has arrived." (while (eq (char-after) ?\ ) (imap-forward) (push (imap-parse-body-extension) b-e)) - (assert (eq (char-after) ?\)) nil "In imap-parse-body-extension") + (cl-assert (eq (char-after) ?\)) nil "In imap-parse-body-extension") (imap-forward) (nreverse b-e)) (or (imap-parse-number) @@ -2716,7 +2698,7 @@ Return nil if no complete line has arrived." (push (imap-parse-string-list) dsp) (imap-forward)) ;; With assert, the code might not be eval'd. - ;; (assert (imap-parse-nil) t "In imap-parse-body-ext") + ;; (cl-assert (imap-parse-nil) t "In imap-parse-body-ext") (imap-parse-nil)) (push (nreverse dsp) ext)) (when (eq (char-after) ?\ ) ;; body-fld-lang @@ -2813,7 +2795,7 @@ Return nil if no complete line has arrived." (push (and (imap-parse-nil) nil) body)) (setq body (append (imap-parse-body-ext) body))) ;; body-ext-... - (assert (eq (char-after) ?\)) nil "In imap-parse-body") + (cl-assert (eq (char-after) ?\)) nil "In imap-parse-body") (imap-forward) (nreverse body)) @@ -2879,7 +2861,7 @@ Return nil if no complete line has arrived." (push (imap-parse-nstring) body) ;; body-fld-md5 (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part.. - (assert (eq (char-after) ?\)) nil "In imap-parse-body 2") + (cl-assert (eq (char-after) ?\)) nil "In imap-parse-body 2") (imap-forward) (nreverse body))))) diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el index b106de02e9b..720c9c178f8 100644 --- a/lisp/net/ldap.el +++ b/lisp/net/ldap.el @@ -646,12 +646,7 @@ an alist of attribute/value pairs." (not (equal "" sizelimit))) (setq arglist (nconc arglist (list (format "-z%s" sizelimit))))) (if passwd - ;; Work around Bug#33154, see also Bug#33050. Leaving - ;; process-connection-type at its default (typically t) - ;; would probably be fine too, however this is the minimal - ;; change on the release branch that fixes ldap.el on Darwin - ;; and leaves other operating systems unchanged. - (let* ((process-connection-type (eq system-type 'darwin)) + (let* ((process-connection-type t) (proc-args (append arglist ldap-ldapsearch-args filter)) (proc (apply #'start-process "ldapsearch" buf diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el index f0694b79ea0..a8ade01e818 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -36,6 +36,14 @@ :version "21.1" :group 'mime) +(defcustom mailcap-prefer-mailcap-viewers t + "If non-nil, prefer viewers specified in ~/.mailcap. +If nil, the most specific viewer will be chosen, even if there is +a general override in ~/.mailcap. For instance, if /etc/mailcap +has an entry for \"image/gif\", that one will be chosen even if +you have an entry for \"image/*\" in your ~/.mailcap file." + :type 'boolean) + (defvar mailcap-parse-args-syntax-table (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) (modify-syntax-entry ?' "\"" table) @@ -419,20 +427,32 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus ((memq system-type mailcap-poor-system-types) (setq path '("~/.mailcap" "~/mail.cap" "~/etc/mail.cap"))) (t (setq path - ;; This is per RFC 1524, specifically - ;; with /usr before /usr/local. - '("~/.mailcap" "/etc/mailcap" "/usr/etc/mailcap" - "/usr/local/etc/mailcap")))) - (dolist (fname (reverse - (if (stringp path) - (split-string path path-separator t) - path))) - (when (and (file-readable-p fname) (file-regular-p fname)) - (mailcap-parse-mailcap fname))) + ;; This is per RFC 1524, specifically with /usr before + ;; /usr/local. + '("~/.mailcap" + ("/etc/mailcap" 'after) + ("/usr/etc/mailcap" 'after) + ("/usr/local/etc/mailcap" 'after))))) + ;; We read the entries from ~/.mailcap before the built-in values, + ;; but place the rest of then afterwards as fallback values. + (dolist (spec (reverse + (if (stringp path) + (split-string path path-separator t) + path))) + (let ((afterp (and (consp spec) + (cadr spec))) + (file-name (if (stringp spec) + spec + (car spec)))) + (when (and (file-readable-p file-name) + (file-regular-p file-name)) + (mailcap-parse-mailcap file-name afterp)))) (setq mailcap-parsed-p t))) -(defun mailcap-parse-mailcap (fname) - "Parse out the mailcap file specified by FNAME." +(defun mailcap-parse-mailcap (fname &optional after) + "Parse out the mailcap file specified by FNAME. +If AFTER, place the entries from the file after the ones that are +already there." (let (major ; The major mime type (image/audio/etc) minor ; The minor mime type (gif, basic, etc) save-pos ; Misc saved positions used in parsing @@ -502,7 +522,7 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus "*" minor)))) (mailcap-parse-mailcap-extras save-pos (point)))) (mailcap-mailcap-entry-passes-test info) - (mailcap-add-mailcap-entry major minor info)) + (mailcap-add-mailcap-entry major minor info after)) (beginning-of-line))))) (defun mailcap-parse-mailcap-extras (st nd) @@ -685,7 +705,7 @@ to supply to the test." (push (list otest result) mailcap-viewer-test-cache) result)))) -(defun mailcap-add-mailcap-entry (major minor info) +(defun mailcap-add-mailcap-entry (major minor info &optional after) (let ((old-major (assoc major mailcap-mime-data))) (if (null old-major) ; New major area (push (cons major (list (cons minor info))) mailcap-mime-data) @@ -693,15 +713,23 @@ to supply to the test." (cond ((or (null cur-minor) ; New minor area, or (assq 'test info)) ; Has a test, insert at beginning - (setcdr old-major (cons (cons minor info) (cdr old-major)))) + (setcdr old-major + (if after ; Or after, if specified. + (nconc (cdr old-major) + (list (cons minor info))) + (cons (cons minor info) (cdr old-major))))) ((and (not (assq 'test info)) ; No test info, replace completely (not (assq 'test cur-minor)) (equal (assq 'viewer info) ; Keep alternative viewer (assq 'viewer cur-minor))) - (setcdr cur-minor info)) + (unless after + (setcdr cur-minor info))) (t - (setcdr old-major (cons (cons minor info) (cdr old-major)))))) - ))) + (setcdr old-major + (if after + (nconc (cdr old-major) (list (cons minor info))) + (setcdr old-major + (cons (cons minor info) (cdr old-major))))))))))) (defun mailcap-add (type viewer &optional test) "Add VIEWER as a handler for TYPE. @@ -784,18 +812,23 @@ If NO-DECODE is non-nil, don't decode STRING." (setq passed (list viewer)) ;; None found, so heuristically select some applicable viewer ;; from `mailcap-mime-data'. + (mailcap-parse-mailcaps) (setq major (split-string (car ctl) "/")) (setq minor (cadr major) major (car major)) (when (setq major-info (cdr (assoc major mailcap-mime-data))) (when (setq viewers (mailcap-possible-viewers major-info minor)) - (setq info (mapcar (lambda (a) (cons (symbol-name (car a)) - (cdr a))) + (setq info (mapcar (lambda (a) + (cons (symbol-name (car a)) (cdr a))) (cdr ctl))) (dolist (entry viewers) (when (mailcap-viewer-passes-test entry info) (push entry passed))) - (setq passed (sort passed 'mailcap-viewer-lessp)) + ;; The data is in "logical" order; entries from ~/.mailcap + ;; are first, so we don't need to do any sorting if the + ;; user wants ~/.mailcap to be preferred. + (unless mailcap-prefer-mailcap-viewers + (setq passed (sort passed 'mailcap-viewer-lessp))) (setq viewer (car passed)))) (when (and (stringp (cdr (assq 'viewer viewer))) passed) @@ -1006,6 +1039,14 @@ If FORCE, re-parse even if already parsed." (setq extn (concat "." extn))) (cdr (assoc (downcase extn) mailcap-mime-extensions))) +(defun mailcap-file-name-to-mime-type (file-name) + "Return the MIME content type based on the FILE-NAME's extension. +For instance, \"foo.png\" will result in \"image/png\"." + (mailcap-extension-to-mime + (if (string-match "\\(\\.[^.]+\\)\\'" file-name) + (match-string 1 file-name) + ""))) + (defun mailcap-mime-types () "Return a list of MIME media types." (mailcap-parse-mimetypes) diff --git a/lisp/net/net-utils.el b/lisp/net/net-utils.el index 9edd42b857a..c9e80804bd3 100644 --- a/lisp/net/net-utils.el +++ b/lisp/net/net-utils.el @@ -86,8 +86,6 @@ These options can be used to limit how many ICMP packets are emitted." :group 'net-utils :type '(repeat string)) -(define-obsolete-variable-alias 'ipconfig-program 'ifconfig-program "22.2") - (defcustom ifconfig-program (cond ((eq system-type 'windows-nt) "ipconfig") ((executable-find "ifconfig") "ifconfig") @@ -99,9 +97,6 @@ These options can be used to limit how many ICMP packets are emitted." :group 'net-utils :type 'string) -(define-obsolete-variable-alias 'ipconfig-program-options - 'ifconfig-program-options "22.2") - (defcustom ifconfig-program-options (cond ((string-match "ipconfig\\'" ifconfig-program) '("/all")) ((string-match "ifconfig\\'" ifconfig-program) '("-a")) diff --git a/lisp/net/netrc.el b/lisp/net/netrc.el index ec743dcff0c..7b974ebf616 100644 --- a/lisp/net/netrc.el +++ b/lisp/net/netrc.el @@ -63,12 +63,14 @@ "port")) alist elem result pair) (if (and netrc-cache - (equal (car netrc-cache) (nth 5 (file-attributes file)))) + (equal (car netrc-cache) (file-attribute-modification-time + (file-attributes file)))) (insert (base64-decode-string (rot13-string (cdr netrc-cache)))) (insert-file-contents file) (when (string-match "\\.gpg\\'" file) ;; Store the contents of the file heavily encrypted in memory. - (setq netrc-cache (cons (nth 5 (file-attributes file)) + (setq netrc-cache (cons (file-attribute-modification-time + (file-attributes file)) (rot13-string (base64-encode-string (buffer-string))))))) diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index f55f5486b62..a0589e25a44 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -42,14 +42,20 @@ ;;; Code: -(require 'tls) -(require 'starttls) (require 'auth-source) (require 'nsm) (require 'puny) +(declare-function starttls-available-p "starttls" ()) +(declare-function starttls-negotiate "starttls" (process)) + (autoload 'gnutls-negotiate "gnutls") (autoload 'open-gnutls-stream "gnutls") +(defvar starttls-extra-arguments) +(defvar starttls-extra-args) +(defvar starttls-use-gnutls) +(defvar starttls-gnutls-program) +(defvar starttls-program) ;;;###autoload (defun open-network-stream (name buffer host service &rest parameters) @@ -255,7 +261,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (or (gnutls-available-p) (and (or require-tls (plist-get parameters :use-starttls-if-possible)) - (starttls-available-p)))) + (require 'starttls) + (starttls-available-p)))) (not (eq (plist-get parameters :type) 'plain))) ;; If using external STARTTLS, drop this connection and start ;; anew with `starttls-open-stream'. @@ -295,7 +302,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (if (gnutls-available-p) (let ((cert (network-stream-certificate host service parameters))) (condition-case nil - (gnutls-negotiate :process stream :hostname host + (gnutls-negotiate :process stream + :hostname (puny-encode-domain host) :keylist (and cert (list cert))) ;; If we get a gnutls-specific error (for instance if ;; the certificate the server gives us is completely @@ -335,7 +343,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." ;; See `starttls-available-p'. If this predicate ;; changes to allow running under Windows, the error ;; message below should be amended. - (if (memq system-type '(windows-nt ms-dos)) + (if (or (memq system-type '(windows-nt ms-dos)) + (not (featurep 'starttls))) (concat "Emacs does not support TLS") (concat "Emacs does not support TLS, and no external `" (if starttls-use-gnutls @@ -372,6 +381,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (unless (= start (point)) (buffer-substring start (point))))))) +(declare-function open-tls-stream "tls" (name buffer host port)) + (defun network-stream-open-tls (name buffer host service parameters) (with-current-buffer buffer (let* ((start (point-max)) @@ -379,6 +390,7 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (if (gnutls-available-p) (open-gnutls-stream name buffer host service (plist-get parameters :nowait)) + (require 'tls) (open-tls-stream name buffer host service))) (eoc (plist-get parameters :end-of-command))) (if (plist-get parameters :nowait) @@ -405,6 +417,9 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (network-stream-command stream capability-command eo-capa) 'tls))))))) +(declare-function format-spec "format-spec" (format spec)) +(declare-function format-spec-make "format-spec" (&rest pairs)) + (defun network-stream-open-shell (name buffer host service parameters) (require 'format-spec) (let* ((capability-command (plist-get parameters :capability-command)) diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index 71a1e31d73a..40096ca4c1e 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -1,4 +1,4 @@ -;;; newst-backend.el --- Retrieval backend for newsticker. +;;; newst-backend.el --- Retrieval backend for newsticker -*- lexical-binding:t -*- ;; Copyright (C) 2003-2018 Free Software Foundation, Inc. @@ -170,7 +170,7 @@ These were mostly extracted from the Radio Community Server at http://subhonker6.userland.com/rcsPublic/rssHotlist. You may add other entries in `newsticker-url-list'." - :type `(set ,@(mapcar `newsticker--splicer + :type `(set ,@(mapcar #'newsticker--splicer newsticker--raw-url-list-defaults)) :set 'newsticker--set-customvar-retrieval :group 'newsticker-retrieval) @@ -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) @@ -876,11 +874,12 @@ Argument BUFFER is the buffer of the retrieval process." (decode-coding-region (point-min) (point-max) coding-system)) (condition-case errordata - ;; The xml parser might fail or the xml might be - ;; bugged + ;; The xml parser might fail or the xml might be bugged. (if (fboundp 'libxml-parse-xml-region) - (list (libxml-parse-xml-region (point-min) (point-max) - nil t)) + (progn + (xml-remove-comments (point-min) (point-max)) + (list (libxml-parse-xml-region (point-min) (point-max) + nil))) (xml-parse-region (point-min) (point-max))) (error (message "Could not parse %s: %s" (buffer-name) (cadr errordata)) @@ -1255,9 +1254,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 +1289,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 +1304,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 +1339,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 +1398,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 +1479,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 +1514,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 +1751,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 +1766,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,8 +1799,9 @@ If the file does no exist or if it is older than 24 hours download it from URL first." (let ((image-name (concat directory feed-name))) (if (and (file-exists-p image-name) - (time-less-p (current-time) - (time-add (nth 5 (file-attributes image-name)) + (time-less-p nil + (time-add (file-attribute-modification-time + (file-attributes image-name)) (seconds-to-time 86400)))) (newsticker--debug-msg "%s: Getting image for %s skipped" (format-time-string "%A, %H:%M") @@ -1853,7 +1842,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 +1903,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 +1997,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 +2009,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 +2282,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 +2350,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 +2396,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 +2488,7 @@ This function is suited for adding it to `newsticker-new-item-functions'." ;; ====================================================================== ;;; Retrieve samples ;; ====================================================================== -(defun newsticker-retrieve-random-message (feed-name) +(defun newsticker-retrieve-random-message (_feed-name) "Return an artificial RSS string under the name FEED-NAME." (concat "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?><rss version=\"0.91\">" "<channel>" diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el index 1e37276a242..889404ef098 100644 --- a/lisp/net/newst-plainview.el +++ b/lisp/net/newst-plainview.el @@ -562,7 +562,6 @@ This does NOT start the retrieval timers." (newsticker--debug-msg "Getting news for %s" (symbol-name feed)) (newsticker-get-news (symbol-name feed))))) -(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) (declare-function w3m-toggle-inline-image "ext:w3m" (&optional force no-cache)) (defun newsticker-w3m-show-inline-images () diff --git a/lisp/net/newst-treeview.el b/lisp/net/newst-treeview.el index 7f3d5d75fdb..59a57293ee8 100644 --- a/lisp/net/newst-treeview.el +++ b/lisp/net/newst-treeview.el @@ -36,6 +36,7 @@ ;; ====================================================================== ;;; Code: +(require 'cl-lib) (require 'newst-reader) (require 'widget) (require 'tree-widget) @@ -258,7 +259,6 @@ their id stays constant." ;; ====================================================================== -(unless (fboundp 'declare-function) (defmacro declare-function (&rest _))) (declare-function w3m-toggle-inline-images "ext:w3m" (&optional force no-cache)) (defvar w3m-fill-column) (defvar w3-maximum-line-length) diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index 3f33e822d04..e857e64be84 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -26,6 +26,7 @@ (require 'cl-lib) (require 'rmc) ; read-multiple-choice +(eval-when-compile (require 'subr-x)) (defvar nsm-permanent-host-settings nil) (defvar nsm-temporary-host-settings nil) @@ -118,12 +119,10 @@ unencrypted." process)))))) (defun nsm-check-tls-connection (process host port status settings) - (let ((process (nsm-check-certificate process host port status settings))) - (if (and process - (>= (nsm-level network-security-level) (nsm-level 'high))) - ;; Do further protocol-level checks if the security is high. - (nsm-check-protocol process host port status settings) - process))) + (when-let ((process + (nsm-check-certificate process host port status settings))) + ;; Do further protocol-level checks. + (nsm-check-protocol process host port status settings))) (declare-function gnutls-peer-status-warning-describe "gnutls.c" (status-symbol)) @@ -182,57 +181,104 @@ unencrypted." nil) process)))))) +(defvar network-security-protocol-checks + '((diffie-hellman-prime-bits medium 1024) + (rc4 medium) + (signature-sha1 medium) + (intermediate-sha1 medium) + (3des high) + (ssl medium)) + "This variable specifies what TLS connection checks to perform. +It's an alist where the first element is the name of the check, +the second is the security level where the check kicks in, and the +optional third element is a parameter supplied to the check. + +An element like `(rc4 medium)' will result in the function +`nsm-protocol-check--rc4' being called with the parameters +HOST PORT STATUS OPTIONAL-PARAMETER.") + (defun nsm-check-protocol (process host port status settings) - (let ((prime-bits (plist-get status :diffie-hellman-prime-bits)) - (signature-algorithm - (plist-get (plist-get status :certificate) :signature-algorithm)) - (encryption (format "%s-%s-%s" - (plist-get status :key-exchange) - (plist-get status :cipher) - (plist-get status :mac))) - (protocol (plist-get status :protocol))) - (cond - ((and prime-bits - (< prime-bits 1024) - (not (memq :diffie-hellman-prime-bits - (plist-get settings :conditions))) - (not - (nsm-query - host port status :diffie-hellman-prime-bits - "The Diffie-Hellman prime bits (%s) used for this connection to %s:%s is less than what is considered safe (%s)." - prime-bits host port 1024))) - (delete-process process) - nil) - ((and (string-match "\\bRC4\\b" encryption) - (not (memq :rc4 (plist-get settings :conditions))) - (not - (nsm-query - host port status :rc4 - "The connection to %s:%s uses the RC4 algorithm (%s), which is believed to be unsafe." - host port encryption))) - (delete-process process) - nil) - ((and (string-match "\\bSHA1\\b" signature-algorithm) - (not (memq :signature-sha1 (plist-get settings :conditions))) - (not - (nsm-query - host port status :signature-sha1 - "The certificate used to verify the connection to %s:%s uses the SHA1 algorithm (%s), which is believed to be unsafe." - host port signature-algorithm))) - (delete-process process) - nil) - ((and protocol - (string-match "SSL" protocol) - (not (memq :ssl (plist-get settings :conditions))) - (not - (nsm-query - host port status :ssl - "The connection to %s:%s uses the %s protocol, which is believed to be unsafe." - host port protocol))) - (delete-process process) - nil) - (t - process)))) + (cl-loop for check in network-security-protocol-checks + for type = (intern (format ":%s" (car check)) obarray) + while process + ;; Skip the check if the user has already said that this + ;; host is OK for this type of "error". + when (and (not (memq type (plist-get settings :conditions))) + (>= (nsm-level network-security-level) + (nsm-level (cadr check)))) + do (let ((result + (funcall (intern (format "nsm-protocol-check--%s" + (car check)) + obarray) + host port status (nth 2 check)))) + (unless result + (delete-process process) + (setq process nil)))) + ;; If a test failed we return nil, otherwise the process object. + process) + +(defun nsm--encryption (status) + (format "%s-%s-%s" + (plist-get status :key-exchange) + (plist-get status :cipher) + (plist-get status :mac))) + +(defun nsm-protocol-check--diffie-hellman-prime-bits (host port status bits) + (let ((prime-bits (plist-get status :diffie-hellman-prime-bits))) + (or (not prime-bits) + (>= prime-bits bits) + (nsm-query + host port status :diffie-hellman-prime-bits + "The Diffie-Hellman prime bits (%s) used for this connection to %s:%s is less than what is considered safe (%s)." + prime-bits host port bits)))) + +(defun nsm-protocol-check--3des (host port status _) + (or (not (string-match "\\b3DES\\b" (plist-get status :cipher))) + (nsm-query + host port status :rc4 + "The connection to %s:%s uses the 3DES cipher (%s), which is believed to be unsafe." + host port (plist-get status :cipher)))) + +(defun nsm-protocol-check--rc4 (host port status _) + (or (not (string-match "\\bRC4\\b" (nsm--encryption status))) + (nsm-query + host port status :rc4 + "The connection to %s:%s uses the RC4 algorithm (%s), which is believed to be unsafe." + host port (nsm--encryption status)))) + +(defun nsm-protocol-check--signature-sha1 (host port status _) + (let ((signature-algorithm + (plist-get (plist-get status :certificate) :signature-algorithm))) + (or (not (string-match "\\bSHA1\\b" signature-algorithm)) + (nsm-query + host port status :signature-sha1 + "The certificate used to verify the connection to %s:%s uses the SHA1 algorithm (%s), which is believed to be unsafe." + host port signature-algorithm)))) + +(defun nsm-protocol-check--intermediate-sha1 (host port status _) + ;; Skip the first certificate, because that's the host certificate. + (cl-loop for certificate in (cdr (plist-get status :certificates)) + for algo = (plist-get certificate :signature-algorithm) + ;; Don't check root certificates -- SHA1 isn't dangerous + ;; there. + when (and (not (equal (plist-get certificate :issuer) + (plist-get certificate :subject))) + (string-match "\\bSHA1\\b" algo) + (not (nsm-query + host port status :intermediate-sha1 + "An intermediate certificate used to verify the connection to %s:%s uses the SHA1 algorithm (%s), which is believed to be unsafe." + host port algo))) + do (cl-return nil) + finally (cl-return t))) + +(defun nsm-protocol-check--ssl (host port status _) + (let ((protocol (plist-get status :protocol))) + (or (not protocol) + (not (string-match "SSL" protocol)) + (nsm-query + host port status :ssl + "The connection to %s:%s uses the %s protocol, which is believed to be unsafe." + host port protocol)))) (defun nsm-fingerprint (status) (plist-get (plist-get status :certificate) :public-key-id)) diff --git a/lisp/net/ntlm.el b/lisp/net/ntlm.el index 8366bc14e95..142c37510ec 100644 --- a/lisp/net/ntlm.el +++ b/lisp/net/ntlm.el @@ -1,4 +1,4 @@ -;;; ntlm.el --- NTLM (NT LanManager) authentication support +;;; ntlm.el --- NTLM (NT LanManager) authentication support -*- lexical-binding:t -*- ;; Copyright (C) 2001, 2007-2018 Free Software Foundation, Inc. @@ -106,7 +106,7 @@ is not given." (request-flags (concat (make-string 1 7) (make-string 1 130) (make-string 1 8) (make-string 1 0))) ;0x07 0x82 0x08 0x00 - lu ld off-d off-u) + ) (when (and user (string-match "@" user)) (unless domain (setq domain (substring user (1+ (match-beginning 0))))) @@ -115,10 +115,10 @@ is not given." ;; set "negotiate domain supplied" bit (aset request-flags 1 (logior (aref request-flags 1) ?\x10))) ;; set fields offsets within the request struct - (setq lu (length user)) - (setq ld (length domain)) - (setq off-u 32) ;offset to the string 'user - (setq off-d (+ 32 lu)) ;offset to the string 'domain + (let* ((lu (length user)) + (ld (length domain)) + (off-u 32) ;offset to the string 'user + (off-d (+ 32 lu))) ;offset to the string 'domain ;; pack the request struct in a string (concat request-ident ;8 bytes request-msgType ;4 bytes @@ -131,39 +131,34 @@ is not given." (md4-pack-int32 (cons 0 off-d)) ;domain field, offset field user ;buffer field domain ;buffer field - ))) - -(eval-when-compile - (defmacro ntlm-string-as-unibyte (string) - (if (fboundp 'string-as-unibyte) - `(string-as-unibyte ,string) - string))) + )))) (defun ntlm-compute-timestamp () "Compute an NTLMv2 timestamp. Return a unibyte string representing the number of tenths of a microsecond since January 1, 1601 as a 64-bit little-endian signed integer." + ;; FIXME: This can likely be significantly simplified using the new + ;; bignums support! (let* ((s-to-tenths-of-us "mul(add(lsh($1,16),$2),10000000)") (us-to-tenths-of-us "mul($3,10)") (ps-to-tenths-of-us "idiv($4,100000)") (tenths-of-us-since-jan-1-1601 - (apply 'calc-eval (concat "add(add(add(" + (apply #'calc-eval (concat "add(add(add(" s-to-tenths-of-us "," us-to-tenths-of-us ")," ps-to-tenths-of-us ")," ;; tenths of microseconds between ;; 1601-01-01 and 1970-01-01 "116444736000000000)") - ;; add trailing zeros to support old current-time formats - 'rawnum (append (current-time) '(0 0)))) + 'rawnum (encode-time nil 'list))) result-bytes) - (dotimes (byte 8) + (dotimes (_byte 8) (push (calc-eval "and($1,16#FF)" 'rawnum tenths-of-us-since-jan-1-1601) result-bytes) (setq tenths-of-us-since-jan-1-1601 (calc-eval "rsh($1,8,64)" 'rawnum tenths-of-us-since-jan-1-1601))) - (apply 'unibyte-string (nreverse result-bytes)))) + (apply #'unibyte-string (nreverse result-bytes)))) (defun ntlm-generate-nonce () "Generate a random nonce, not to be used more than once. @@ -178,7 +173,13 @@ the NTLM based server for the user USER and the password hash list PASSWORD-HASHES. NTLM uses two hash values which are represented by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of (list (ntlm-smb-passwd-hash password) (ntlm-md4hash password))" - (let* ((rchallenge (ntlm-string-as-unibyte challenge)) + (let* ((rchallenge (if (multibyte-string-p challenge) + (progn + ;; FIXME: Maybe it would be better to + ;; signal an error. + (message "Incorrect challenge string type in ntlm-build-auth-response") + (encode-coding-string challenge 'binary)) + challenge)) ;; get fields within challenge struct ;;(ident (substring rchallenge 0 8)) ;ident, 8 bytes ;;(msgType (substring rchallenge 8 12)) ;msgType, 4 bytes @@ -189,20 +190,16 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of ;0x07 0x82 0x08 0x00 (flags (substring rchallenge 20 24)) ;flags, 4 bytes (challengeData (substring rchallenge 24 32)) ;challengeData, 8 bytes - uDomain-len uDomain-offs - ;; response struct and its fields + ;; Extract domain string from challenge string. + ;;(uDomain-len (md4-unpack-int16 (substring uDomain 0 2))) + (uDomain-offs (md4-unpack-int32 (substring uDomain 4 8))) + ;; Response struct and its fields. lmRespData ;lmRespData, 24 bytes ntRespData ;ntRespData, variable length - domain ;ascii domain string - workstation ;ascii workstation string - ll ln lu ld lw off-lm off-nt off-u off-d off-w) - ;; extract domain string from challenge string - (setq uDomain-len (md4-unpack-int16 (substring uDomain 0 2))) - (setq uDomain-offs (md4-unpack-int32 (substring uDomain 4 8))) - ;; match Mozilla behavior, which is to send an empty domain string - (setq domain "") - ;; match Mozilla behavior, which is to send "WORKSTATION" - (setq workstation "WORKSTATION") + ;; Match Mozilla behavior, which is to send an empty domain string + (domain "") ;ascii domain string + ;; Match Mozilla behavior, which is to send "WORKSTATION". + (workstation "WORKSTATION")) ;ascii workstation string ;; overwrite domain in case user is given in <user>@<domain> format (when (string-match "@" user) (setq domain (substring user (1+ (match-beginning 0)))) @@ -261,13 +258,11 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of ;; so just treat it the same as levels 0 and 1 ;; check if "negotiate NTLM2 key" flag is set in type 2 message (if (not (zerop (logand (aref flags 2) 8))) - (let (randomString - sessionHash) - ;; generate NTLM2 session response data - (setq randomString (ntlm-generate-nonce)) - (setq sessionHash (secure-hash 'md5 + ;; generate NTLM2 session response data + (let* ((randomString (ntlm-generate-nonce)) + (sessionHash (secure-hash 'md5 (concat challengeData randomString) - nil nil t)) + nil nil t))) (setq sessionHash (substring sessionHash 0 8)) (setq lmRespData (concat randomString (make-string 16 0))) (setq ntRespData (ntlm-smb-owf-encrypt @@ -279,16 +274,16 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of (ntlm-smb-owf-encrypt (cadr password-hashes) challengeData)))) ;; get offsets to fields to pack the response struct in a string - (setq ll (length lmRespData)) - (setq ln (length ntRespData)) - (setq lu (length user)) - (setq ld (length domain)) - (setq lw (length workstation)) - (setq off-u 64) ;offset to string 'uUser - (setq off-d (+ off-u (* 2 lu))) ;offset to string 'uDomain - (setq off-w (+ off-d (* 2 ld))) ;offset to string 'uWks - (setq off-lm (+ off-w (* 2 lw))) ;offset to string 'lmResponse - (setq off-nt (+ off-lm ll)) ;offset to string 'ntResponse + (let* ((ll (length lmRespData)) + (ln (length ntRespData)) + (lu (length user)) + (ld (length domain)) + (lw (length workstation)) + (off-u 64) ;offset to string 'uUser + (off-d (+ off-u (* 2 lu))) ;offset to string 'uDomain + (off-w (+ off-d (* 2 ld))) ;offset to string 'uWks + (off-lm (+ off-w (* 2 lw))) ;offset to string 'lmResponse + (off-nt (+ off-lm ll))) ;offset to string 'ntResponse ;; pack the response struct in a string (concat "NTLMSSP\0" ;response ident field, 8 bytes (md4-pack-int32 '(0 . 3)) ;response msgType field, 4 bytes @@ -342,7 +337,7 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of (ntlm-ascii2unicode workstation lw) ;Unicode workstation, 2*lw bytes lmRespData ;lmResponse, 24 bytes ntRespData ;ntResponse, ln bytes - ))) + )))) (defun ntlm-get-password-hashes (password) "Return a pair of SMB hash and NT MD4 hash of the given password PASSWORD." @@ -352,7 +347,10 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of (defun ntlm-ascii2unicode (str len) "Convert an ASCII string into a NT Unicode string, which is little-endian utf16." - (let ((utf (make-string (* 2 len) 0)) (i 0) val) + ;; FIXME: Can't we use encode-coding-string with a `utf-16le' coding system? + (let ((utf (make-string (* 2 len) 0)) + (i 0) + val) (while (and (< i len) (not (zerop (setq val (aref str i))))) (aset utf (* 2 i) val) @@ -381,9 +379,9 @@ string PASSWD. PASSWD is truncated to 14 bytes if longer." "Return the response string of 24 bytes long for the given password string PASSWD based on the DES encryption. PASSWD is of at most 14 bytes long and the challenge string C8 of 8 bytes long." - (let ((len (min (length passwd) 16)) p22) - (setq p22 (concat (substring passwd 0 len) ;fill top 16 bytes with passwd - (make-string (- 22 len) 0))) + (let* ((len (min (length passwd) 16)) + (p22 (concat (substring passwd 0 len) ;Fill top 16 bytes with passwd. + (make-string (- 22 len) 0)))) (ntlm-smb-des-e-p24 p22 c8))) (defun ntlm-smb-des-e-p24 (p22 c8) @@ -405,53 +403,53 @@ string C8." "Return the hash string of length 8 for a string IN of length 8 and a string KEY of length 8. FORW is t or nil." (let ((out (make-string 8 0)) - outb ;string of length 64 (inb (make-string 64 0)) (keyb (make-string 64 0)) (key2 (ntlm-smb-str-to-key key)) - (i 0) aa) + (i 0)) (while (< i 64) - (unless (zerop (logand (aref in (/ i 8)) (lsh 1 (- 7 (% i 8))))) + (unless (zerop (logand (aref in (/ i 8)) (ash 1 (- 7 (% i 8))))) (aset inb i 1)) - (unless (zerop (logand (aref key2 (/ i 8)) (lsh 1 (- 7 (% i 8))))) + (unless (zerop (logand (aref key2 (/ i 8)) (ash 1 (- 7 (% i 8))))) (aset keyb i 1)) (setq i (1+ i))) - (setq outb (ntlm-smb-dohash inb keyb forw)) - (setq i 0) - (while (< i 64) - (unless (zerop (aref outb i)) - (setq aa (aref out (/ i 8))) - (aset out (/ i 8) - (logior aa (lsh 1 (- 7 (% i 8)))))) - (setq i (1+ i))) - out)) + (let ((outb (ntlm-smb-dohash inb keyb forw)) + aa) + (setq i 0) + (while (< i 64) + (unless (zerop (aref outb i)) + (setq aa (aref out (/ i 8))) + (aset out (/ i 8) + (logior aa (ash 1 (- 7 (% i 8)))))) + (setq i (1+ i))) + out))) (defun ntlm-smb-str-to-key (str) "Return a string of length 8 for the given string STR of length 7." (let ((key (make-string 8 0)) (i 7)) - (aset key 0 (lsh (aref str 0) -1)) + (aset key 0 (ash (aref str 0) -1)) (aset key 1 (logior - (lsh (logand (aref str 0) 1) 6) - (lsh (aref str 1) -2))) + (ash (logand (aref str 0) 1) 6) + (ash (aref str 1) -2))) (aset key 2 (logior - (lsh (logand (aref str 1) 3) 5) - (lsh (aref str 2) -3))) + (ash (logand (aref str 1) 3) 5) + (ash (aref str 2) -3))) (aset key 3 (logior - (lsh (logand (aref str 2) 7) 4) - (lsh (aref str 3) -4))) + (ash (logand (aref str 2) 7) 4) + (ash (aref str 3) -4))) (aset key 4 (logior - (lsh (logand (aref str 3) 15) 3) - (lsh (aref str 4) -5))) + (ash (logand (aref str 3) 15) 3) + (ash (aref str 4) -5))) (aset key 5 (logior - (lsh (logand (aref str 4) 31) 2) - (lsh (aref str 5) -6))) + (ash (logand (aref str 4) 31) 2) + (ash (aref str 5) -6))) (aset key 6 (logior - (lsh (logand (aref str 5) 63) 1) - (lsh (aref str 6) -7))) + (ash (logand (aref str 5) 63) 1) + (ash (aref str 6) -7))) (aset key 7 (logand (aref str 6) 127)) (while (>= i 0) - (aset key i (lsh (aref key i) 1)) + (aset key i (ash (aref key i) 1)) (setq i (1- i))) key)) @@ -571,27 +569,22 @@ length of STR is LEN." "Return the hash value for a string IN and a string KEY. Length of IN and KEY are 64. FORW non-nil means forward, nil means backward." - (let (pk1 ;string of length 56 - c ;string of length 28 - d ;string of length 28 - cd ;string of length 56 - (ki (make-vector 16 0)) ;vector of string of length 48 - pd1 ;string of length 64 - l ;string of length 32 - r ;string of length 32 - rl ;string of length 64 - (i 0) (j 0) (k 0)) - (setq pk1 (ntlm-string-permute key ntlm-smb-perm1 56)) - (setq c (substring pk1 0 28)) - (setq d (substring pk1 28 56)) - - (setq i 0) - (while (< i 16) + (let* ((pk1 (ntlm-string-permute key ntlm-smb-perm1 56)) ;string of length 56 + (c (substring pk1 0 28)) ;string of length 28 + (d (substring pk1 28 56)) ;string of length 28 + cd ;string of length 56 + (ki (make-vector 16 0)) ;vector of string of length 48 + pd1 ;string of length 64 + l ;string of length 32 + r ;string of length 32 + rl ;string of length 64 + (i 0) (j 0) (k 0)) + + (dotimes (i 16) (setq c (ntlm-string-lshift c (aref ntlm-smb-sc i) 28)) (setq d (ntlm-string-lshift d (aref ntlm-smb-sc i) 28)) (setq cd (concat (substring c 0 28) (substring d 0 28))) - (aset ki i (ntlm-string-permute cd ntlm-smb-perm2 48)) - (setq i (1+ i))) + (aset ki i (ntlm-string-permute cd ntlm-smb-perm2 48))) (setq pd1 (ntlm-string-permute in ntlm-smb-perm3 64)) @@ -619,16 +612,16 @@ backward." (setq j 0) (while (< j 8) (setq bj (aref b j)) - (setq m (logior (lsh (aref bj 0) 1) (aref bj 5))) - (setq n (logior (lsh (aref bj 1) 3) - (lsh (aref bj 2) 2) - (lsh (aref bj 3) 1) + (setq m (logior (ash (aref bj 0) 1) (aref bj 5))) + (setq n (logior (ash (aref bj 1) 3) + (ash (aref bj 2) 2) + (ash (aref bj 3) 1) (aref bj 4))) (setq k 0) (setq sbox-jmn (aref (aref (aref ntlm-smb-sbox j) m) n)) (while (< k 4) (aset bj k - (if (zerop (logand sbox-jmn (lsh 1 (- 3 k)))) + (if (zerop (logand sbox-jmn (ash 1 (- 3 k)))) 0 1)) (setq k (1+ k))) (setq j (1+ j))) @@ -650,16 +643,12 @@ backward." (defun ntlm-md4hash (passwd) "Return the 16 bytes MD4 hash of a string PASSWD after converting it into a Unicode string. PASSWD is truncated to 128 bytes if longer." - (let (len wpwd) - ;; Password cannot be longer than 128 characters - (setq len (length passwd)) - (if (> len 128) - (setq len 128)) - ;; Password must be converted to NT Unicode - (setq wpwd (ntlm-ascii2unicode passwd len)) - ;; Calculate length in bytes - (setq len (* len 2)) - (md4 wpwd len))) + (let* ((len (min (length passwd) 128)) ;Pwd can't be > than 128 characters. + ;; Password must be converted to NT Unicode. + (wpwd (ntlm-ascii2unicode passwd len))) + (md4 wpwd + ;; Calculate length in bytes. + (* len 2)))) (provide 'ntlm) diff --git a/lisp/net/pop3.el b/lisp/net/pop3.el index c2385f7f7e5..2a6807e1aca 100644 --- a/lisp/net/pop3.el +++ b/lisp/net/pop3.el @@ -1,4 +1,4 @@ -;;; pop3.el --- Post Office Protocol (RFC 1460) interface +;;; pop3.el --- Post Office Protocol (RFC 1460) interface -*- lexical-binding:t -*- ;; Copyright (C) 1996-2018 Free Software Foundation, Inc. @@ -32,7 +32,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'mail-utils) (defvar parse-time-months) @@ -237,8 +237,8 @@ Use streaming commands." (setq start-point (pop3-wait-for-messages process pop3-stream-length total-size start-point)) - (incf waited-for pop3-stream-length)) - (incf i)) + (cl-incf waited-for pop3-stream-length)) + (cl-incf i)) (pop3-wait-for-messages process (- count waited-for) total-size start-point))) @@ -249,7 +249,7 @@ Use streaming commands." (or (not total-size) (re-search-forward "^\\.\r?\n" nil t))) (re-search-forward "^-ERR " nil t)) - (decf count) + (cl-decf count) (setq start-point (point))) (unless (memq (process-status process) '(open run)) (error "pop3 process died")) @@ -269,7 +269,6 @@ Use streaming commands." (defun pop3-write-to-file (file messages) (let ((pop-buffer (current-buffer)) - (start (point-min)) beg end temp-buffer) (with-temp-buffer @@ -280,7 +279,6 @@ Use streaming commands." (forward-line 1) (setq beg (point)) (when (re-search-forward "^\\.\r?\n" nil t) - (setq start (point)) (forward-line -1) (setq end (point))) (with-current-buffer temp-buffer @@ -369,7 +367,7 @@ Use streaming commands." (while (> i 0) (unless (member (nth (1- i) pop3-uidl) saved) (push i messages)) - (decf i))) + (cl-decf i))) (when messages (setq list (pop3-list process) size 0) @@ -399,7 +397,7 @@ Return non-nil if it is necessary to update the local UIDL file." (unless (member (setq uidl (nth i pop3-uidl)) (cdr saved)) (push ctime new) (push uidl new)) - (decf i))) + (cl-decf i))) (pop3-uidl (setq new (mapcan (lambda (elt) (list elt ctime)) pop3-uidl)))) (when new (setq mod t)) @@ -424,7 +422,7 @@ Return non-nil if it is necessary to update the local UIDL file." (push uidl new))) ;; Mails having been deleted in the server. (setq mod t)) - (decf i 2)) + (cl-decf i 2)) (cond (saved (setcdr saved new)) (srvr @@ -440,7 +438,7 @@ Return non-nil if it is necessary to update the local UIDL file." (while (> i 0) (when (member (nth (1- i) pop3-uidl) dele) (push i uidl)) - (decf i)) + (cl-decf i)) (when uidl (pop3-send-streaming-command process "DELE" uidl nil))) mod)) @@ -620,10 +618,8 @@ Return the response string if optional second argument is non-nil." If NOW, use that time instead." (require 'parse-time) (let* ((now (or now (current-time))) - (zone (nth 8 (decode-time now))) - (sign "+")) + (zone (nth 8 (decode-time now)))) (when (< zone 0) - (setq sign "-") (setq zone (- zone))) (concat (format-time-string "%d" now) @@ -785,7 +781,7 @@ Otherwise, return the size of the message-id MSG" (pop3-send-command process (format "DELE %s" msg)) (pop3-read-response process)) -(defun pop3-noop (process msg) +(defun pop3-noop (process _msg) "No-operation." (pop3-send-command process "NOOP") (pop3-read-response process)) diff --git a/lisp/net/puny.el b/lisp/net/puny.el index 4bf1a372cb4..efa11cf178d 100644 --- a/lisp/net/puny.el +++ b/lisp/net/puny.el @@ -27,6 +27,7 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) (require 'seq) (defun puny-encode-domain (domain) diff --git a/lisp/net/quickurl.el b/lisp/net/quickurl.el index abfca383e09..ff14d20bc32 100644 --- a/lisp/net/quickurl.el +++ b/lisp/net/quickurl.el @@ -155,7 +155,7 @@ could be used here." (defconst quickurl-reread-hook-postfix " ;; Local Variables: -;; eval: (progn (require 'quickurl) (add-hook 'local-write-file-hooks (lambda () (quickurl-read) nil))) +;; eval: (progn (require 'quickurl) (add-hook 'write-file-functions (lambda () (quickurl-read) nil) nil t)) ;; End: " "Example `quickurl-postfix' text that adds a local variable to the @@ -504,15 +504,15 @@ TYPE dictates what will be inserted, options are: (with-current-buffer quickurl-list-last-buffer (insert (pcase type - (`url (funcall quickurl-format-function url)) - (`naked-url (quickurl-url-url url)) - (`with-lookup (format "%s <URL:%s>" + ('url (funcall quickurl-format-function url)) + ('naked-url (quickurl-url-url url)) + ('with-lookup (format "%s <URL:%s>" (quickurl-url-keyword url) (quickurl-url-url url))) - (`with-desc (format "%S <URL:%s>" + ('with-desc (format "%S <URL:%s>" (quickurl-url-description url) (quickurl-url-url url))) - (`lookup (quickurl-url-keyword url))))) + ('lookup (quickurl-url-keyword url))))) (error "No URL details on that line")) url)) diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 7fc3e349287..0c72e478830 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -168,6 +168,14 @@ underneath each nick." (string :tag "Prefix text")) :group 'rcirc) +(defcustom rcirc-url-max-length nil + "Maximum number of characters in displayed URLs. +If nil, no maximum is applied." + :version "27.1" + :type '(choice (const :tag "No maximum" nil) + (integer :tag "Number of characters")) + :group 'rcirc) + (defvar rcirc-ignore-buffer-activity-flag nil "If non-nil, ignore activity in this buffer.") (make-variable-buffer-local 'rcirc-ignore-buffer-activity-flag) @@ -186,9 +194,6 @@ underneath each nick." (define-minor-mode rcirc-omit-mode "Toggle the hiding of \"uninteresting\" lines. -With a prefix argument ARG, enable Rcirc-Omit mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. Uninteresting lines are those whose responses are listed in `rcirc-omit-responses'." @@ -1353,10 +1358,7 @@ Create the buffer if it doesn't exist." "Keymap for multiline mode in rcirc.") (define-minor-mode rcirc-multiline-minor-mode - "Minor mode for editing multiple lines in rcirc. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "Minor mode for editing multiple lines in rcirc." :init-value nil :lighter " rcirc-mline" :keymap rcirc-multiline-minor-mode-map @@ -1867,10 +1869,7 @@ This function does not alter the INPUT string." ;;;###autoload (define-minor-mode rcirc-track-minor-mode - "Global minor mode for tracking activity in rcirc buffers. -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil." + "Global minor mode for tracking activity in rcirc buffers." :init-value nil :lighter "" :keymap rcirc-track-minor-mode-map @@ -2494,24 +2493,26 @@ If ARG is given, opens the URL in a new browser window." (rcirc-record-activity (current-buffer) 'nick))))) (defun rcirc-markup-urls (_sender _response) - (while (and rcirc-url-regexp ;; nil means disable URL catching + (while (and rcirc-url-regexp ; nil means disable URL catching. (re-search-forward rcirc-url-regexp nil t)) (let* ((start (match-beginning 0)) - (end (match-end 0)) - (url (match-string-no-properties 0)) - (link-text (buffer-substring-no-properties start end))) + (url (buffer-substring-no-properties start (point)))) + (when rcirc-url-max-length + ;; Replace match with truncated URL. + (delete-region start (point)) + (insert (url-truncate-url-for-viewing url rcirc-url-max-length))) ;; Add a button for the URL. Note that we use `make-text-button', ;; rather than `make-button', as text-buttons are much faster in ;; large buffers. - (make-text-button start end + (make-text-button start (point) 'face 'rcirc-url 'follow-link t 'rcirc-url url 'action (lambda (button) (browse-url (button-get button 'rcirc-url)))) - ;; record the url if it is not already the latest stored url - (when (not (string= link-text (caar rcirc-urls))) - (push (cons link-text start) rcirc-urls))))) + ;; Record the URL if it is not already the latest stored URL. + (unless (string= url (caar rcirc-urls)) + (push (cons url start) rcirc-urls))))) (defun rcirc-markup-keywords (sender response) (when (and (string= response "PRIVMSG") @@ -2796,10 +2797,7 @@ the only argument." "RPL_WHOISIDLE" (let* ((nick (nth 1 args)) (idle-secs (string-to-number (nth 2 args))) - (idle-string - (if (< idle-secs most-positive-fixnum) - (format-seconds "%yy %dd %hh %mm %z%ss" idle-secs) - "a very long time")) + (idle-string (format-seconds "%yy %dd %hh %mm %z%ss" idle-secs)) (signon-time (seconds-to-time (string-to-number (nth 3 args)))) (signon-string (format-time-string "%c" signon-time)) (message (format "%s idle for %s, signed on %s" diff --git a/lisp/net/rfc2104.el b/lisp/net/rfc2104.el index d974ab6a772..57bca2e8788 100644 --- a/lisp/net/rfc2104.el +++ b/lisp/net/rfc2104.el @@ -1,4 +1,4 @@ -;;; rfc2104.el --- RFC2104 Hashed Message Authentication Codes +;;; rfc2104.el --- RFC2104 Hashed Message Authentication Codes -*- lexical-binding:t -*- ;; Copyright (C) 1998-2018 Free Software Foundation, Inc. @@ -55,7 +55,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; Magic character for inner HMAC round. 0x36 == 54 == '6' (defconst rfc2104-ipad ?\x36) @@ -101,7 +101,7 @@ In XEmacs return just STRING." (opad (make-string (+ block-length hash-length) rfc2104-opad)) c partial) ;; Prefix *pad with key, appropriately XORed. - (do ((i 0 (1+ i))) + (cl-do ((i 0 (1+ i))) ((= len i)) (setq c (aref key i)) (aset ipad i (logxor rfc2104-ipad c)) @@ -110,8 +110,8 @@ In XEmacs return just STRING." (setq partial (rfc2104-string-make-unibyte (funcall hash (concat ipad text)))) ;; Pack latter part of opad. - (do ((r 0 (+ 2 r)) - (w block-length (1+ w))) + (cl-do ((r 0 (+ 2 r)) + (w block-length (1+ w))) ((= (* 2 hash-length) r)) (aset opad w (+ (* 16 (aref rfc2104-nybbles (aref partial r))) diff --git a/lisp/net/rlogin.el b/lisp/net/rlogin.el index 3bfc4d7f356..015e04f4075 100644 --- a/lisp/net/rlogin.el +++ b/lisp/net/rlogin.el @@ -1,4 +1,4 @@ -;;; rlogin.el --- remote login interface +;;; rlogin.el --- remote login interface -*- lexical-binding:t -*- ;; Copyright (C) 1992-1995, 1997-1998, 2001-2018 Free Software ;; Foundation, Inc. @@ -30,9 +30,9 @@ ;; tracking and the sending of some special characters. ;; If you wish for rlogin mode to prompt you in the minibuffer for -;; passwords when a password prompt appears, just enter m-x send-invisible -;; and type in your line, or add `comint-watch-for-password-prompt' to -;; `comint-output-filter-functions'. +;; passwords when a password prompt appears, just enter +;; M-x comint-send-invisible and type in your line (or tweak +;; `comint-password-prompt-regexp' to match your password prompt). ;;; Code: diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el index b4f0fffc716..ca0b66b2fb6 100644 --- a/lisp/net/sasl.el +++ b/lisp/net/sasl.el @@ -183,7 +183,7 @@ It contain at least 64 bits of entropy." ;; Don't use microseconds from (current-time), they may be unsupported. ;; Instead we use this randomly inited counter. (setq sasl-unique-id-char - (% (1+ (or sasl-unique-id-char (logand (random) (1- (lsh 1 20))))) + (% (1+ (or sasl-unique-id-char (logand (random) (1- (ash 1 20))))) ;; (current-time) returns 16-bit ints, ;; and 2^16*25 just fits into 4 digits i base 36. (* 25 25))) @@ -191,10 +191,10 @@ It contain at least 64 bits of entropy." (concat (sasl-unique-id-number-base36 (+ (car tm) - (lsh (% sasl-unique-id-char 25) 16)) 4) + (ash (% sasl-unique-id-char 25) 16)) 4) (sasl-unique-id-number-base36 (+ (nth 1 tm) - (lsh (/ sasl-unique-id-char 25) 16)) 4)))) + (ash (/ sasl-unique-id-char 25) 16)) 4)))) (defun sasl-unique-id-number-base36 (num len) (if (if (< len 0) diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el index c4685483161..ca75d953c43 100644 --- a/lisp/net/secrets.el +++ b/lisp/net/secrets.el @@ -158,7 +158,7 @@ (defvar secrets-enabled nil "Whether there is a daemon offering the Secret Service API.") -(defvar secrets-debug t +(defvar secrets-debug nil "Write debug messages") (defconst secrets-service "org.freedesktop.secrets" @@ -331,9 +331,7 @@ It returns t if not." ;; Properties. `(:array (:dict-entry ,(concat secrets-interface-item ".Label") - (:variant "dummy")) - (:dict-entry ,(concat secrets-interface-item ".Type") - (:variant ,secrets-interface-item-type-generic))) + (:variant " "))) ;; Secret. `(:struct :object-path ,path (:array :signature "y") @@ -539,6 +537,18 @@ For the time being, only the alias \"default\" is supported." secrets-interface-service "SetAlias" alias :object-path secrets-empty-path)) +(defun secrets-lock-collection (collection) + "Lock collection labeled COLLECTION. +If successful, return the object path of the collection." + (let ((collection-path (secrets-collection-path collection))) + (unless (secrets-empty-path collection-path) + (secrets-prompt + (cadr + (dbus-call-method + :session secrets-service secrets-path secrets-interface-service + "Lock" `(:array :object-path ,collection-path))))) + collection-path)) + (defun secrets-unlock-collection (collection) "Unlock collection labeled COLLECTION. If successful, return the object path of the collection." @@ -565,7 +575,6 @@ If successful, return the object path of the collection." (defun secrets-get-items (collection-path) "Return the object paths of all available items in COLLECTION-PATH." (unless (secrets-empty-path collection-path) - (secrets-open-session) (dbus-get-property :session secrets-service collection-path secrets-interface-collection "Items"))) @@ -593,16 +602,16 @@ If successful, return the object path of the collection." (secrets-get-item-property item-path "Label")) (secrets-get-items collection-path))))) -(defun secrets-search-items (collection &rest attributes) +(defun secrets-search-item-paths (collection &rest attributes) "Search items in COLLECTION with ATTRIBUTES. ATTRIBUTES are key-value pairs. The keys are keyword symbols, starting with a colon. Example: - (secrets-search-items \"Tramp collection\" :user \"joe\") + (secrets-search-item-paths \"Tramp collection\" :user \"joe\") -The object labels of the found items are returned as list." +The object paths of the found items are returned as list." (let ((collection-path (secrets-unlock-collection collection)) - result props) + props) (unless (secrets-empty-path collection-path) ;; Create attributes list. (while (consp (cdr attributes)) @@ -617,84 +626,109 @@ The object labels of the found items are returned as list." ,(cadr attributes)))) attributes (cddr attributes))) ;; Search. The result is a list of object paths. - (setq result - (dbus-call-method - :session secrets-service collection-path - secrets-interface-collection "SearchItems" - (if props - (cons :array props) - '(:array :signature "{ss}")))) - ;; Return the found items. - (mapcar - (lambda (item-path) (secrets-get-item-property item-path "Label")) - result)))) + (dbus-call-method + :session secrets-service collection-path + secrets-interface-collection "SearchItems" + (if props + (cons :array props) + '(:array :signature "{ss}")))))) + +(defun secrets-search-items (collection &rest attributes) + "Search items in COLLECTION with ATTRIBUTES. +ATTRIBUTES are key-value pairs. The keys are keyword symbols, +starting with a colon. Example: + + (secrets-search-items \"Tramp collection\" :user \"joe\") + +The object labels of the found items are returned as list." + (mapcar + (lambda (item-path) (secrets-get-item-property item-path "Label")) + (apply 'secrets-search-item-paths collection attributes))) (defun secrets-create-item (collection item password &rest attributes) "Create a new item in COLLECTION with label ITEM and password PASSWORD. +The label ITEM does not have to be unique in COLLECTION. ATTRIBUTES are key-value pairs set for the created item. The keys are keyword symbols, starting with a colon. Example: (secrets-create-item \"Tramp collection\" \"item\" \"geheim\" :method \"sudo\" :user \"joe\" :host \"remote-host\") +The key `:xdg:schema' determines the scope of the item to be +generated, i.e. for which applications the item is intended for. +This is just a string like \"org.freedesktop.NetworkManager.Mobile\" +or \"org.gnome.OnlineAccounts\", the other required keys are +determined by this. If no `:xdg:schema' is given, +\"org.freedesktop.Secret.Generic\" is used by default. + The object path of the created item is returned." - (unless (member item (secrets-list-items collection)) - (let ((collection-path (secrets-unlock-collection collection)) - result props) - (unless (secrets-empty-path collection-path) - ;; Create attributes list. - (while (consp (cdr attributes)) - (unless (keywordp (car attributes)) - (error 'wrong-type-argument (car attributes))) - (unless (stringp (cadr attributes)) - (error 'wrong-type-argument (cadr attributes))) - (setq props (append - props - `((:dict-entry - ,(substring (symbol-name (car attributes)) 1) - ,(cadr attributes)))) - attributes (cddr attributes))) - ;; Create the item. - (setq result - (dbus-call-method - :session secrets-service collection-path - secrets-interface-collection "CreateItem" - ;; Properties. - (append - `(:array - (:dict-entry ,(concat secrets-interface-item ".Label") - (:variant ,item)) - (:dict-entry ,(concat secrets-interface-item ".Type") - (:variant ,secrets-interface-item-type-generic))) - (when props - `((:dict-entry ,(concat secrets-interface-item ".Attributes") - (:variant ,(append '(:array) props)))))) - ;; Secret. - (append - `(:struct :object-path ,secrets-session-path - (:array :signature "y") ;; No parameters. - ,(dbus-string-to-byte-array password)) - ;; We add the content_type. In backward compatibility - ;; mode, nil is appended, which means nothing. - secrets-struct-secret-content-type) - ;; Do not replace. Replace does not seem to work. - nil)) - (secrets-prompt (cadr result)) - ;; Return the object path. - (car result))))) + (let ((collection-path (secrets-unlock-collection collection)) + result props) + (unless (secrets-empty-path collection-path) + ;; Set default type if needed. + (unless (member :xdg:schema attributes) + (setq attributes + (append + attributes `(:xdg:schema ,secrets-interface-item-type-generic)))) + ;; Create attributes list. + (while (consp (cdr attributes)) + (unless (keywordp (car attributes)) + (error 'wrong-type-argument (car attributes))) + (unless (stringp (cadr attributes)) + (error 'wrong-type-argument (cadr attributes))) + (setq props (append + props + `((:dict-entry + ,(substring (symbol-name (car attributes)) 1) + ,(cadr attributes)))) + attributes (cddr attributes))) + ;; Create the item. + (setq result + (dbus-call-method + :session secrets-service collection-path + secrets-interface-collection "CreateItem" + ;; Properties. + (append + `(:array + (:dict-entry ,(concat secrets-interface-item ".Label") + (:variant ,item))) + (when props + `((:dict-entry ,(concat secrets-interface-item ".Attributes") + (:variant ,(append '(:array) props)))))) + ;; Secret. + (append + `(:struct :object-path ,secrets-session-path + (:array :signature "y") ;; No parameters. + ,(dbus-string-to-byte-array password)) + ;; We add the content_type. In backward compatibility + ;; mode, nil is appended, which means nothing. + secrets-struct-secret-content-type) + ;; Do not replace. Replace does not seem to work. + nil)) + (secrets-prompt (cadr result)) + ;; Return the object path. + (car result)))) (defun secrets-item-path (collection item) "Return the object path of item labeled ITEM in COLLECTION. -If there is no such item, return nil." +If there are several items labeled ITEM, it is undefined which +one is returned. If there is no such item, return nil. + +ITEM can also be an object path, which is returned if contained in COLLECTION." (let ((collection-path (secrets-unlock-collection collection))) - (catch 'item-found - (dolist (item-path (secrets-get-items collection-path)) - (when (string-equal item (secrets-get-item-property item-path "Label")) - (throw 'item-found item-path)))))) + (or (and (member item (secrets-get-items collection-path)) item) + (catch 'item-found + (dolist (item-path (secrets-get-items collection-path)) + (when (string-equal + item (secrets-get-item-property item-path "Label")) + (throw 'item-found item-path))))))) (defun secrets-get-secret (collection item) "Return the secret of item labeled ITEM in COLLECTION. -If there is no such item, return nil." +If there are several items labeled ITEM, it is undefined which +one is returned. If there is no such item, return nil. + +ITEM can also be an object path, which is used if contained in COLLECTION." (let ((item-path (secrets-item-path collection item))) (unless (secrets-empty-path item-path) (dbus-byte-array-to-string @@ -705,8 +739,11 @@ If there is no such item, return nil." (defun secrets-get-attributes (collection item) "Return the lookup attributes of item labeled ITEM in COLLECTION. -If there is no such item, or the item has no attributes, return nil." - (unless (stringp collection) (setq collection "default")) +If there are several items labeled ITEM, it is undefined which +one is returned. If there is no such item, or the item has no +attributes, return nil. + +ITEM can also be an object path, which is used if contained in COLLECTION." (let ((item-path (secrets-item-path collection item))) (unless (secrets-empty-path item-path) (mapcar @@ -718,11 +755,19 @@ If there is no such item, or the item has no attributes, return nil." (defun secrets-get-attribute (collection item attribute) "Return the value of ATTRIBUTE of item labeled ITEM in COLLECTION. -If there is no such item, or the item doesn't own this attribute, return nil." +If there are several items labeled ITEM, it is undefined which +one is returned. If there is no such item, or the item doesn't +own this attribute, return nil. + +ITEM can also be an object path, which is used if contained in COLLECTION." (cdr (assoc attribute (secrets-get-attributes collection item)))) (defun secrets-delete-item (collection item) - "Delete ITEM in COLLECTION." + "Delete item labeled ITEM in COLLECTION. +If there are several items labeled ITEM, it is undefined which +one is deleted. + +ITEM can also be an object path, which is used if contained in COLLECTION." (let ((item-path (secrets-item-path collection item))) (unless (secrets-empty-path item-path) (secrets-prompt @@ -872,6 +917,8 @@ to their attributes." (when (dbus-ping :session secrets-service 100) + (secrets-open-session) + ;; We must reset all variables, when there is a new instance of the ;; "org.freedesktop.secrets" service. (dbus-register-signal diff --git a/lisp/net/shr-color.el b/lisp/net/shr-color.el index ca7d1ce55a4..6303141c898 100644 --- a/lisp/net/shr-color.el +++ b/lisp/net/shr-color.el @@ -1,4 +1,4 @@ -;;; shr-color.el --- Simple HTML Renderer color management +;;; shr-color.el --- Simple HTML Renderer color management -*- lexical-binding:t -*- ;; Copyright (C) 2010-2018 Free Software Foundation, Inc. @@ -27,7 +27,7 @@ ;;; Code: (require 'color) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup shr-color nil "Simple HTML Renderer colors" @@ -210,8 +210,8 @@ This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"." (defun shr-color-hue-to-rgb (x y h) "Convert X Y H to RGB value." - (when (< h 0) (incf h)) - (when (> h 1) (decf h)) + (when (< h 0) (cl-incf h)) + (when (> h 1) (cl-decf h)) (cond ((< h (/ 6.0)) (+ x (* (- y x) h 6))) ((< h 0.5) y) ((< h (/ 2.0 3.0)) (+ x (* (- y x) (- (/ 2.0 3.0) h) 6))) @@ -259,8 +259,7 @@ Like rgb() or hsl()." (let ((h (/ (string-to-number (match-string-no-properties 1 color)) 360.0)) (s (/ (string-to-number (match-string-no-properties 2 color)) 100.0)) (l (/ (string-to-number (match-string-no-properties 3 color)) 100.0))) - (destructuring-bind (r g b) - (shr-color-hsl-to-rgb-fractions h s l) + (pcase-let ((`(,r ,g ,b) (shr-color-hsl-to-rgb-fractions h s l))) (color-rgb-to-hex r g b 2)))) ;; Color names ((cdr (assoc-string color shr-color-html-colors-alist t))) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 364f289e1ab..7ef1e18a1a0 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -30,7 +30,7 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) (eval-when-compile (require 'url)) ;For url-filename's setf handler. (require 'browse-url) (eval-when-compile (require 'subr-x)) @@ -38,6 +38,8 @@ (require 'seq) (require 'svg) (require 'image) +(require 'puny) +(require 'text-property-search) (defgroup shr nil "Simple HTML Renderer" @@ -66,6 +68,13 @@ fit these criteria." :group 'shr :type 'boolean) +(defcustom shr-discard-aria-hidden nil + "If non-nil, don't render tags with `aria-hidden=\"true\"'. +This attribute is meant to tell screen readers to ignore a tag." + :version "27.1" + :group 'shr + :type 'boolean) + (defcustom shr-use-colors t "If non-nil, respect color specifications in the HTML." :version "26.1" @@ -133,13 +142,21 @@ cid: URL as the argument.") (defvar shr-put-image-function 'shr-put-image "Function called to put image and alt string.") -(defface shr-strike-through '((t (:strike-through t))) - "Font for <s> elements." +(defface shr-strike-through '((t :strike-through t)) + "Face for <s> elements." + :version "24.1" :group 'shr) (defface shr-link - '((t (:inherit link))) - "Font for link elements." + '((t :inherit link)) + "Face for link elements." + :version "24.1" + :group 'shr) + +(defface shr-selected-link + '((t :inherit shr-link :background "red")) + "Face for link elements." + :version "27.1" :group 'shr) (defvar shr-inhibit-images nil @@ -267,7 +284,9 @@ DOM should be a parse tree as generated by (if (and (null shr-width) (not (shr--have-one-fringe-p))) (* (frame-char-width) 2) - 0))))) + 0) + 1)))) + (max-specpdl-size max-specpdl-size) bidi-display-reordering) ;; If the window was hscrolled for some reason, shr-fill-lines ;; below will misbehave, because it silently assumes that it @@ -344,52 +363,45 @@ If the URL is already at the front of the kill ring act like (shr-probe-and-copy-url url) (shr-copy-url url))) +(defun shr--current-link-region () + (let ((current (get-text-property (point) 'shr-url)) + start) + (save-excursion + ;; Go to the beginning. + (while (and (not (bobp)) + (equal (get-text-property (point) 'shr-url) current)) + (forward-char -1)) + (unless (equal (get-text-property (point) 'shr-url) current) + (forward-char 1)) + (setq start (point)) + ;; Go to the end. + (while (and (not (eobp)) + (equal (get-text-property (point) 'shr-url) current)) + (forward-char 1)) + (list start (point))))) + +(defun shr--blink-link () + (let* ((region (shr--current-link-region)) + (overlay (make-overlay (car region) (cadr region)))) + (overlay-put overlay 'face 'shr-selected-link) + (run-at-time 1 nil (lambda () + (delete-overlay overlay))))) + (defun shr-next-link () "Skip to the next link." (interactive) - (let ((current (get-text-property (point) 'shr-url)) - (start (point)) - skip) - (while (and (not (eobp)) - (equal (get-text-property (point) 'shr-url) current)) - (forward-char 1)) - (cond - ((and (not (eobp)) - (get-text-property (point) 'shr-url)) - ;; The next link is adjacent. - (message "%s" (get-text-property (point) 'help-echo))) - ((or (eobp) - (not (setq skip (text-property-not-all (point) (point-max) - 'shr-url nil)))) - (goto-char start) - (message "No next link")) - (t - (goto-char skip) - (message "%s" (get-text-property (point) 'help-echo)))))) + (let ((match (text-property-search-forward 'shr-url nil nil t))) + (if (not match) + (message "No next link") + (goto-char (prop-match-beginning match)) + (message "%s" (get-text-property (point) 'help-echo))))) (defun shr-previous-link () "Skip to the previous link." (interactive) - (let ((start (point)) - (found nil)) - ;; Skip past the current link. - (while (and (not (bobp)) - (get-text-property (point) 'help-echo)) - (forward-char -1)) - ;; Find the previous link. - (while (and (not (bobp)) - (not (setq found (get-text-property (point) 'help-echo)))) - (forward-char -1)) - (if (not found) - (progn - (message "No previous link") - (goto-char start)) - ;; Put point at the start of the link. - (while (and (not (bobp)) - (get-text-property (point) 'help-echo)) - (forward-char -1)) - (forward-char 1) - (message "%s" (get-text-property (point) 'help-echo))))) + (if (not (text-property-search-backward 'shr-url nil nil t)) + (message "No previous link") + (message "%s" (get-text-property (point) 'help-echo)))) (defun shr-show-alt-text () "Show the ALT text of the image under point." @@ -493,15 +505,20 @@ size, and full-buffer size." (shr-depth (1+ shr-depth)) (start (point))) ;; shr uses many frames per nested node. - (if (> shr-depth (/ max-specpdl-size 15)) - (setq shr-warning "Too deeply nested to render properly; consider increasing `max-specpdl-size'") + (if (and (> shr-depth (/ max-specpdl-size 15)) + (not (and (y-or-n-p "Too deeply nested to render properly; increase `max-specpdl-size'?") + (setq max-specpdl-size (* max-specpdl-size 2))))) + (setq shr-warning + "Not rendering the complete page because of too-deep nesting") (when style (if (string-match "color\\|display\\|border-collapse" style) (setq shr-stylesheet (nconc (shr-parse-style style) shr-stylesheet)) (setq style nil))) ;; If we have a display:none, then just ignore this part of the DOM. - (unless (equal (cdr (assq 'display shr-stylesheet)) "none") + (unless (or (equal (cdr (assq 'display shr-stylesheet)) "none") + (and shr-discard-aria-hidden + (equal (dom-attr dom 'aria-hidden) "true"))) ;; We don't use shr-indirect-call here, since shr-descend is ;; the central bit of shr.el, and should be as fast as ;; possible. Having one more level of indirection with its @@ -689,37 +706,47 @@ size, and full-buffer size." `,(shr-face-background face)))) (setq start (point)) (setq shr-indentation (or continuation shr-indentation)) - (shr-vertical-motion shr-internal-width) - (when (looking-at " $") - (delete-region (point) (line-end-position))) - (while (not (eolp)) - ;; We have to do some folding. First find the first - ;; previous point suitable for folding. - (if (or (not (shr-find-fill-point (line-beginning-position))) - (= (point) start)) - ;; We had unbreakable text (for this width), so just go to - ;; the first space and carry on. - (progn - (beginning-of-line) - (skip-chars-forward " ") - (search-forward " " (line-end-position) 'move))) - ;; Success; continue. - (when (= (preceding-char) ?\s) - (delete-char -1)) - (let ((props `(face ,(get-text-property (point) 'face) - ;; Don't break the image-displayer property - ;; as it will cause `gnus-article-show-images' - ;; to show the two or more same images. - image-displayer - ,(get-text-property (point) 'image-displayer))) - (gap-start (point))) - (insert "\n") - (shr-indent) - (add-text-properties gap-start (point) props)) - (setq start (point)) + ;; If we have an indentation that's wider than the width we're + ;; trying to fill to, then just give up and don't do any filling. + (when (< shr-indentation shr-internal-width) (shr-vertical-motion shr-internal-width) (when (looking-at " $") - (delete-region (point) (line-end-position)))))) + (delete-region (point) (line-end-position))) + (while (not (eolp)) + ;; We have to do some folding. First find the first + ;; previous point suitable for folding. + (if (or (not (shr-find-fill-point (line-beginning-position))) + (= (point) start)) + ;; We had unbreakable text (for this width), so just go to + ;; the first space and carry on. + (progn + (beginning-of-line) + (skip-chars-forward " ") + (search-forward " " (line-end-position) 'move))) + ;; Success; continue. + (when (= (preceding-char) ?\s) + (delete-char -1)) + (let ((gap-start (point))) + (insert "\n") + (shr-indent) + (when (and (> (1- gap-start) (point-min)) + ;; The link on both sides of the newline are the + ;; same... + (equal (get-text-property (point) 'shr-url) + (get-text-property (1- gap-start) 'shr-url))) + ;; ... so we join the two bits into one link logically, but + ;; not visually. This makes navigation between links work + ;; well, but avoids underscores before the link on the next + ;; line when indented. + (let ((props (copy-sequence (text-properties-at (point))))) + ;; We don't want to use the faces on the indentation, because + ;; that's ugly. + (setq props (plist-put props 'face nil)) + (add-text-properties gap-start (point) props)))) + (setq start (point)) + (shr-vertical-motion shr-internal-width) + (when (looking-at " $") + (delete-region (point) (line-end-position))))))) (defun shr-find-fill-point (start) (let ((bp (point)) @@ -950,7 +977,9 @@ the mouse click event." (browse-url-mail url)) (t (if external - (funcall shr-external-browser url) + (progn + (funcall shr-external-browser url) + (shr--blink-link)) (browse-url url)))))) (defun shr-save-contents (directory) @@ -1178,12 +1207,24 @@ START, and END. Note that START and END should be markers." (add-text-properties start (point) (list 'shr-url url - 'help-echo (let ((iri (or (ignore-errors - (decode-coding-string - (url-unhex-string url) - 'utf-8 t)) - url))) - (if title (format "%s (%s)" iri title) iri)) + 'help-echo (let ((parsed (url-generic-parse-url + (or (ignore-errors + (decode-coding-string + (url-unhex-string url) + 'utf-8 t)) + url))) + iri) + ;; If we have an IDNA domain, then show the + ;; decoded version in the mouseover to let the + ;; user know that there's something possibly + ;; fishy. + (when (url-host parsed) + (setf (url-host parsed) + (puny-encode-domain (url-host parsed)))) + (setq iri (url-recreate-url parsed)) + (if title + (format "%s (%s)" iri title) + iri)) 'follow-link t 'mouse-face 'highlight)) ;; Don't overwrite any keymaps that are already in the buffer (i.e., @@ -1319,19 +1360,19 @@ ones, in case fg and bg are nil." (shr-generic dom) (put-text-property start (point) 'display '(raise -0.5)))) -(defun shr-tag-label (dom) - (shr-generic dom) - (shr-ensure-paragraph)) - (defun shr-tag-p (dom) (shr-ensure-paragraph) (shr-generic dom) (shr-ensure-paragraph)) (defun shr-tag-div (dom) - (shr-ensure-newline) - (shr-generic dom) - (shr-ensure-newline)) + (let ((display (cdr (assq 'display shr-stylesheet)))) + (if (or (equal display "inline") + (equal display "inline-block")) + (shr-generic dom) + (shr-ensure-newline) + (shr-generic dom) + (shr-ensure-newline)))) (defun shr-tag-s (dom) (shr-fontize-dom dom 'shr-strike-through)) @@ -1528,6 +1569,10 @@ The preference is a float determined from `shr-prefer-media-type'." (when (zerop (length alt)) (setq alt "*")) (cond + ((null url) + ;; After further expansion, there turned out to be no valid + ;; src in the img after all. + ) ((or (member (dom-attr dom 'height) '("0" "1")) (member (dom-attr dom 'width) '("0" "1"))) ;; Ignore zero-sized or single-pixel images. diff --git a/lisp/net/sieve-manage.el b/lisp/net/sieve-manage.el index e6a1e8401d2..8c70ae037ab 100644 --- a/lisp/net/sieve-manage.el +++ b/lisp/net/sieve-manage.el @@ -1,4 +1,4 @@ -;;; sieve-manage.el --- Implementation of the managesieve protocol in elisp +;;; sieve-manage.el --- Implementation of the managesieve protocol in elisp -*- lexical-binding:t -*- ;; Copyright (C) 2001-2018 Free Software Foundation, Inc. @@ -75,9 +75,8 @@ (require 'password-cache) (require 'password)) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'sasl) -(require 'starttls) (autoload 'sasl-find-mechanism "sasl") (autoload 'auth-source-search "auth-source") @@ -182,7 +181,7 @@ Valid states are `closed', `initial', `nonauth', and `auth'.") (generate-new-buffer (format " *sieve %s:%s*" sieve-manage-server sieve-manage-port)) - (mapc 'make-local-variable sieve-manage-local-variables) + (mapc #'make-local-variable sieve-manage-local-variables) (mm-enable-multibyte) (buffer-disable-undo) (current-buffer))) @@ -206,19 +205,19 @@ Return the buffer associated with the connection." (with-current-buffer buffer (sieve-manage-erase) (setq sieve-manage-state 'initial) - (destructuring-bind (proc . props) - (open-network-stream - "SIEVE" buffer server port - :type stream - :capability-command "CAPABILITY\r\n" - :end-of-command "^\\(OK\\|NO\\).*\n" - :success "^OK.*\n" - :return-list t - :starttls-function - (lambda (capabilities) - (when (and (not sieve-manage-ignore-starttls) - (string-match "\\bSTARTTLS\\b" capabilities)) - "STARTTLS\r\n"))) + (pcase-let ((`(,proc . ,props) + (open-network-stream + "SIEVE" buffer server port + :type stream + :capability-command "CAPABILITY\r\n" + :end-of-command "^\\(OK\\|NO\\).*\n" + :success "^OK.*\n" + :return-list t + :starttls-function + (lambda (capabilities) + (when (and (not sieve-manage-ignore-starttls) + (string-match "\\bSTARTTLS\\b" capabilities)) + "STARTTLS\r\n"))))) (setq sieve-manage-process proc) (setq sieve-manage-capability (sieve-manage-parse-capability (plist-get props :capabilities))) @@ -250,7 +249,7 @@ Return the buffer associated with the connection." ;; somehow. `(lambda (prompt) ,(copy-sequence user-password))) (step (sasl-next-step client nil)) - (tag (sieve-manage-send + (_tag (sieve-manage-send (concat "AUTHENTICATE \"" mech @@ -373,11 +372,11 @@ to work in." ;; Choose authenticator (when (and (null sieve-manage-auth) (not (eq sieve-manage-state 'auth))) - (dolist (auth sieve-manage-authenticators) + (cl-dolist (auth sieve-manage-authenticators) (when (funcall (nth 1 (assq auth sieve-manage-authenticator-alist)) buffer) (setq sieve-manage-auth auth) - (return))) + (cl-return))) (unless sieve-manage-auth (error "Couldn't figure out authenticator for server"))) (sieve-manage-erase) diff --git a/lisp/net/sieve-mode.el b/lisp/net/sieve-mode.el index 34a4cb611ea..b9f424fda8c 100644 --- a/lisp/net/sieve-mode.el +++ b/lisp/net/sieve-mode.el @@ -100,23 +100,20 @@ (defconst sieve-font-lock-keywords (eval-when-compile - (list - ;; control commands - (cons (regexp-opt '("require" "if" "else" "elsif" "stop") - 'words) - 'sieve-control-commands) - ;; action commands - (cons (regexp-opt '("fileinto" "redirect" "reject" "keep" "discard") - 'words) - 'sieve-action-commands) - ;; test commands - (cons (regexp-opt '("address" "allof" "anyof" "exists" "false" - "true" "header" "not" "size" "envelope" - "body") - 'words) - 'sieve-test-commands) - (cons "\\Sw+:\\sw+" - 'sieve-tagged-arguments)))) + `( + ;; control commands + (,(regexp-opt '("require" "if" "else" "elsif" "stop") 'words) + . 'sieve-control-commands) + ;; action commands + (,(regexp-opt '("fileinto" "redirect" "reject" "keep" "discard") 'words) + . 'sieve-action-commands) + ;; test commands + (,(regexp-opt '("address" "allof" "anyof" "exists" "false" + "true" "header" "not" "size" "envelope" + "body") + 'words) + . 'sieve-test-commands) + ("\\Sw+:\\sw+" . 'sieve-tagged-arguments)))) ;; Syntax table diff --git a/lisp/net/sieve.el b/lisp/net/sieve.el index 1f80ccc1e05..ef7bb5c025c 100644 --- a/lisp/net/sieve.el +++ b/lisp/net/sieve.el @@ -345,11 +345,14 @@ Used to bracket operations which move point in the sieve-buffer." ;;;###autoload (defun sieve-upload (&optional name) (interactive) - (when (or (get-buffer sieve-buffer) (call-interactively 'sieve-manage)) - (let ((script (buffer-string)) err) + (when (or (get-buffer sieve-buffer) + (save-current-buffer (call-interactively 'sieve-manage))) + (let ((script (buffer-string)) + (script-name (file-name-sans-extension (buffer-name))) + err) (with-current-buffer (get-buffer sieve-buffer) (setq err (sieve-manage-putscript - (or name sieve-buffer-script-name (buffer-name)) + (or name sieve-buffer-script-name script-name) script sieve-manage-buffer)) (if (sieve-manage-ok-p err) (message (substitute-command-keys diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index 17f83082f8d..7c409665e44 100644 --- a/lisp/net/soap-client.el +++ b/lisp/net/soap-client.el @@ -5,7 +5,7 @@ ;; Author: Alexandru Harsanyi <AlexHarsanyi@gmail.com> ;; Author: Thomas Fitzsimmons <fitzsim@fitzsim.org> ;; Created: December, 2009 -;; Version: 3.1.4 +;; Version: 3.1.5 ;; Keywords: soap, web-services, comm, hypermedia ;; Package: soap-client ;; Homepage: https://github.com/alex-hhh/emacs-soap-client @@ -685,14 +685,17 @@ This is a specialization of `soap-decode-type' for (anyType (soap-decode-any-type node)) (Array (soap-decode-array node)))))) -(defun soap-type-of (element) - "Return the type of ELEMENT." - ;; Support Emacs < 26 byte-code running in Emacs >= 26 sessions - ;; (Bug#31742). - (let ((type (type-of element))) - (if (eq type 'vector) - (aref element 0) ; For Emacs 25 and earlier. - type))) +(defalias 'soap-type-of + (if (eq 'soap-xs-basic-type (type-of (make-soap-xs-basic-type))) + ;; `type-of' in Emacs ≥ 26 already does what we need. + #'type-of + ;; For Emacs < 26, use our own function. + (lambda (element) + "Return the type of ELEMENT." + (if (vectorp element) + (aref element 0) ;Assume this vector is actually a struct! + ;; This should never happen. + (type-of element))))) ;; Register methods for `soap-xs-basic-type' (let ((tag (soap-type-of (make-soap-xs-basic-type)))) @@ -2334,6 +2337,14 @@ traverse an element tree." (defun soap-parse-server-response () "Error-check and parse the XML contents of the current buffer." (let ((mime-part (mm-dissect-buffer t t))) + (when (and + (equal (mm-handle-media-type mime-part) "multipart/related") + (equal (get-text-property 0 'type (mm-handle-media-type mime-part)) + "text/xml")) + (setq mime-part + (mm-make-handle + (get-text-property 0 'buffer (mm-handle-media-type mime-part)) + `(,(get-text-property 0 'type (mm-handle-media-type mime-part)))))) (unless mime-part (error "Failed to decode response from server")) (unless (equal (car (mm-handle-type mime-part)) "text/xml") @@ -2881,6 +2892,8 @@ reference multiRef parts which are external to RESPONSE-NODE." ;;;; SOAP type encoding +;; FIXME: Use `cl-defmethod' (but this requires Emacs-25). + (defun soap-encode-attributes (value type) "Encode XML attributes for VALUE according to TYPE. This is a generic function which determines the attribute encoder diff --git a/lisp/net/socks.el b/lisp/net/socks.el index 32362e25434..5ee6eea933f 100644 --- a/lisp/net/socks.el +++ b/lisp/net/socks.el @@ -1,4 +1,4 @@ -;;; socks.el --- A Socks v5 Client for Emacs +;;; socks.el --- A Socks v5 Client for Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1996-2000, 2002, 2007-2018 Free Software Foundation, ;; Inc. @@ -32,71 +32,59 @@ ;; - Implement composition of servers. Recursively evaluate the ;; redirection rules and do SOCKS-over-HTTP and SOCKS-in-SOCKS -(eval-when-compile - (require 'wid-edit)) -(require 'custom) - -(eval-and-compile - (if (featurep 'emacs) - (defalias 'socks-split-string 'split-string) ; since at least 21.1 - (if (fboundp 'split-string) - (defalias 'socks-split-string 'split-string) - (defun socks-split-string (string &optional pattern) - "Return a list of substrings of STRING which are separated by PATTERN. -If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." - (or pattern - (setq pattern "[ \f\t\n\r\v]+")) - (let (parts (start 0)) - (while (string-match pattern string start) - (setq parts (cons (substring string start - (match-beginning 0)) parts) - start (match-end 0))) - (nreverse (cons (substring string start) parts))))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Custom widgets -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; (define-widget 'dynamic-choice 'menu-choice -;;; "A pretty simple dynamic dropdown list" -;;; :format "%[%t%]: %v" -;;; :tag "Network" -;;; :case-fold t -;;; :void '(item :format "invalid (%t)\n") -;;; :value-create 's5-widget-value-create -;;; :value-delete 'widget-children-value-delete -;;; :value-get 'widget-choice-value-get -;;; :value-inline 'widget-choice-value-inline -;;; :mouse-down-action 'widget-choice-mouse-down-action -;;; :action 'widget-choice-action -;;; :error "Make a choice" -;;; :validate 'widget-choice-validate -;;; :match 's5-dynamic-choice-match -;;; :match-inline 's5-dynamic-choice-match-inline) -;;; -;;; (defun s5-dynamic-choice-match (widget value) -;;; (let ((choices (funcall (widget-get widget :choice-function))) -;;; current found) -;;; (while (and choices (not found)) -;;; (setq current (car choices) -;;; choices (cdr choices) -;;; found (widget-apply current :match value))) -;;; found)) -;;; -;;; (defun s5-dynamic-choice-match-inline (widget value) -;;; (let ((choices (funcall (widget-get widget :choice-function))) -;;; current found) -;;; (while (and choices (not found)) -;;; (setq current (car choices) -;;; choices (cdr choices) -;;; found (widget-match-inline current value))) -;;; found)) -;;; -;;; (defun s5-widget-value-create (widget) -;;; (let ((choices (funcall (widget-get widget :choice-function))) -;;; (value (widget-get widget :value))) -;;; (if (not value) -;;; (widget-put widget :value (widget-value (car choices)))) -;;; (widget-put widget :args choices) -;;; (widget-choice-value-create widget))) +;;; Code: + +(eval-when-compile (require 'cl-lib)) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;; Custom widgets +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (eval-when-compile +;; (require 'wid-edit)) + +;; (define-widget 'dynamic-choice 'menu-choice +;; "A pretty simple dynamic dropdown list" +;; :format "%[%t%]: %v" +;; :tag "Network" +;; :case-fold t +;; :void '(item :format "invalid (%t)\n") +;; :value-create 's5-widget-value-create +;; :value-delete 'widget-children-value-delete +;; :value-get 'widget-choice-value-get +;; :value-inline 'widget-choice-value-inline +;; :mouse-down-action 'widget-choice-mouse-down-action +;; :action 'widget-choice-action +;; :error "Make a choice" +;; :validate 'widget-choice-validate +;; :match 's5-dynamic-choice-match +;; :match-inline 's5-dynamic-choice-match-inline) +;; +;; (defun s5-dynamic-choice-match (widget value) +;; (let ((choices (funcall (widget-get widget :choice-function))) +;; current found) +;; (while (and choices (not found)) +;; (setq current (car choices) +;; choices (cdr choices) +;; found (widget-apply current :match value))) +;; found)) +;; +;; (defun s5-dynamic-choice-match-inline (widget value) +;; (let ((choices (funcall (widget-get widget :choice-function))) +;; current found) +;; (while (and choices (not found)) +;; (setq current (car choices) +;; choices (cdr choices) +;; found (widget-match-inline current value))) +;; found)) +;; +;; (defun s5-widget-value-create (widget) +;; (let ((choices (funcall (widget-get widget :choice-function))) +;; (value (widget-get widget :value))) +;; (if (not value) +;; (widget-put widget :value (widget-value (car choices)))) +;; (widget-put widget :args choices) +;; (widget-choice-value-create widget))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Customization support @@ -107,70 +95,66 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." :prefix "socks-" :group 'processes) -;;; (defcustom socks-server-aliases nil -;;; "A list of server aliases for use in access control and filtering rules." -;;; :group 'socks -;;; :type '(repeat (list :format "%v" -;;; :value ("" "" 1080 5) -;;; (string :tag "Alias") -;;; (string :tag "Hostname/IP Address") -;;; (integer :tag "Port #") -;;; (choice :tag "SOCKS Version" -;;; (integer :tag "SOCKS v4" :value 4) -;;; (integer :tag "SOCKS v5" :value 5))))) -;;; -;;; (defcustom socks-network-aliases -;;; '(("Anywhere" (netmask "0.0.0.0" "0.0.0.0"))) -;;; "A list of network aliases for use in subsequent rules." -;;; :group 'socks -;;; :type '(repeat (list :format "%v" -;;; :value (netmask "" "255.255.255.0") -;;; (string :tag "Alias") -;;; (radio-button-choice -;;; :format "%v" -;;; (list :tag "IP address range" -;;; (const :format "" :value range) -;;; (string :tag "From") -;;; (string :tag "To")) -;;; (list :tag "IP address/netmask" -;;; (const :format "" :value netmask) -;;; (string :tag "IP Address") -;;; (string :tag "Netmask")) -;;; (list :tag "Domain Name" -;;; (const :format "" :value domain) -;;; (string :tag "Domain name")) -;;; (list :tag "Unique hostname/IP address" -;;; (const :format "" :value exact) -;;; (string :tag "Hostname/IP Address")))))) -;;; -;;; (defun s5-servers-filter () -;;; (if socks-server-aliases -;;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x))) s5-server-aliases) -;;; '((const :tag "No aliases defined" :value nil)))) -;;; -;;; (defun s5-network-aliases-filter () -;;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x))) -;;; socks-network-aliases)) -;;; -;;; (defcustom socks-redirection-rules -;;; nil -;;; "A list of redirection rules." -;;; :group 'socks -;;; :type '(repeat (list :format "%v" -;;; :value ("Anywhere" nil) -;;; (dynamic-choice :choice-function s5-network-aliases-filter -;;; :tag "Destination network") -;;; (radio-button-choice -;;; :tag "Connection type" -;;; (const :tag "Direct connection" :value nil) -;;; (dynamic-choice :format "%t: %[%v%]" -;;; :choice-function s5-servers-filter -;;; :tag "Proxy chain via"))))) +;; (defcustom socks-server-aliases nil +;; "A list of server aliases for use in access control and filtering rules." +;; :type '(repeat (list :format "%v" +;; :value ("" "" 1080 5) +;; (string :tag "Alias") +;; (string :tag "Hostname/IP Address") +;; (integer :tag "Port #") +;; (choice :tag "SOCKS Version" +;; (integer :tag "SOCKS v4" :value 4) +;; (integer :tag "SOCKS v5" :value 5))))) +;; +;; (defcustom socks-network-aliases +;; '(("Anywhere" (netmask "0.0.0.0" "0.0.0.0"))) +;; "A list of network aliases for use in subsequent rules." +;; :type '(repeat (list :format "%v" +;; :value (netmask "" "255.255.255.0") +;; (string :tag "Alias") +;; (radio-button-choice +;; :format "%v" +;; (list :tag "IP address range" +;; (const :format "" :value range) +;; (string :tag "From") +;; (string :tag "To")) +;; (list :tag "IP address/netmask" +;; (const :format "" :value netmask) +;; (string :tag "IP Address") +;; (string :tag "Netmask")) +;; (list :tag "Domain Name" +;; (const :format "" :value domain) +;; (string :tag "Domain name")) +;; (list :tag "Unique hostname/IP address" +;; (const :format "" :value exact) +;; (string :tag "Hostname/IP Address")))))) +;; +;; (defun s5-servers-filter () +;; (if socks-server-aliases +;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x))) s5-server-aliases) +;; '((const :tag "No aliases defined" :value nil)))) +;; +;; (defun s5-network-aliases-filter () +;; (mapcar (lambda (x) (list 'const :tag (car x) :value (car x))) +;; socks-network-aliases)) +;; +;; (defcustom socks-redirection-rules +;; nil +;; "A list of redirection rules." +;; :type '(repeat (list :format "%v" +;; :value ("Anywhere" nil) +;; (dynamic-choice :choice-function s5-network-aliases-filter +;; :tag "Destination network") +;; (radio-button-choice +;; :tag "Connection type" +;; (const :tag "Direct connection" :value nil) +;; (dynamic-choice :format "%t: %[%v%]" +;; :choice-function s5-servers-filter +;; :tag "Proxy chain via"))))) (defcustom socks-server (list "Default server" "socks" 1080 5) "" - :group 'socks :type '(list (string :format "" :value "Default server") (string :tag "Server") @@ -225,7 +209,6 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." ;; Base variables (defvar socks-timeout 5) -(defvar socks-connections (make-hash-table :size 13)) ;; Miscellaneous stuff for authentication (defvar socks-authentication-methods nil) @@ -266,40 +249,40 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (defconst socks-state-waiting 3) (defconst socks-state-connected 4) -(defmacro socks-wait-for-state-change (proc htable cur-state) - `(while (and (= (gethash 'state ,htable) ,cur-state) - (memq (process-status ,proc) '(run open))) - (accept-process-output ,proc socks-timeout))) +(defun socks-wait-for-state-change (proc cur-state) + (while (and (= (process-get proc 'socks-state) cur-state) + (memq (process-status proc) '(run open))) + (accept-process-output proc socks-timeout))) (defun socks-filter (proc string) - (let ((info (gethash proc socks-connections)) - state version desired-len) - (or info (error "socks-filter called on non-SOCKS connection %S" proc)) - (setq state (gethash 'state info)) + (let (state version desired-len) + (or (process-get proc 'socks) + (error "socks-filter called on non-SOCKS connection %S" proc)) + (setq state (process-get proc 'socks-state)) (cond ((= state socks-state-waiting-for-auth) - (puthash 'scratch (concat string (gethash 'scratch info)) info) - (setq string (gethash 'scratch info)) + (cl-callf (lambda (s) (setq string (concat string s))) + (process-get proc 'socks-scratch)) (if (< (length string) 2) nil ; We need to spin some more - (puthash 'authtype (aref string 1) info) - (puthash 'scratch (substring string 2 nil) info) - (puthash 'state socks-state-submethod-negotiation info))) + (process-put proc 'socks-authtype (aref string 1)) + (process-put proc 'socks-scratch (substring string 2 nil)) + (process-put proc 'socks-state socks-state-submethod-negotiation))) ((= state socks-state-submethod-negotiation) ) ((= state socks-state-authenticated) ) ((= state socks-state-waiting) - (puthash 'scratch (concat string (gethash 'scratch info)) info) - (setq string (gethash 'scratch info)) - (setq version (gethash 'server-protocol info)) + (cl-callf (lambda (s) (setq string (concat string s))) + (process-get proc 'socks-scratch)) + (setq version (process-get proc 'socks-server-protocol)) (cond ((equal version 'http) (if (not (string-match "\r\n\r\n" string)) nil ; Need to spin some more - (puthash 'state socks-state-connected info) - (puthash 'reply 0 info) - (puthash 'response string info))) + (process-put proc 'socks-state socks-state-connected) + (process-put proc 'socks-reply 0) + (process-put proc 'socks-response string))) ((equal version 4) (if (< (length string) 2) nil ; Can't know how much to read yet @@ -313,71 +296,58 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (let ((response (aref string 1))) (if (= response 90) (setq response 0)) - (puthash 'state socks-state-connected info) - (puthash 'reply response info) - (puthash 'response string info))))) + (process-put proc 'socks-state socks-state-connected) + (process-put proc 'socks-reply response) + (process-put proc 'socks-response string))))) ((equal version 5) (if (< (length string) 4) nil (setq desired-len (+ 6 ; Standard socks header - (cond - ((= (aref string 3) socks-address-type-v4) 4) - ((= (aref string 3) socks-address-type-v6) 16) - ((= (aref string 3) socks-address-type-name) - (if (< (length string) 5) - 255 - (+ 1 (aref string 4))))))) + (pcase (aref string 3) + ((pred (= socks-address-type-v4)) 4) + ((pred (= socks-address-type-v6)) 16) + ((pred (= socks-address-type-name)) + (if (< (length string) 5) + 255 + (+ 1 (aref string 4))))))) (if (< (length string) desired-len) nil ; Need to spin some more - (puthash 'state socks-state-connected info) - (puthash 'reply (aref string 1) info) - (puthash 'response string info)))))) - ((= state socks-state-connected) - ) - ) - ) - ) - -(declare-function socks-original-open-network-stream "socks") ; fset + (process-put proc 'socks-state socks-state-connected) + (process-put proc 'socks-reply (aref string 1)) + (process-put proc 'socks-response string)))))) + ((= state socks-state-connected))))) ;; FIXME this is a terrible idea. ;; It is not even compatible with the argument spec of open-network-stream -;; in 24.1. If this is really necessary, open-network-stream -;; could get a wrapper hook, or defer to open-network-stream-function. +;; in 24.1. (defvar socks-override-functions nil - "Whether to overwrite the `open-network-stream' function with the SOCKSified -version.") - -(require 'network-stream) + "If non-nil, overwrite `open-network-stream' function with SOCKSified version.") -(if (fboundp 'socks-original-open-network-stream) - nil ; Do nothing, we've been here already - (defalias 'socks-original-open-network-stream - (symbol-function 'open-network-stream)) - (if socks-override-functions - (defalias 'open-network-stream 'socks-open-network-stream))) +(when socks-override-functions + (advice-add 'open-network-stream :around #'socks--open-network-stream)) (defun socks-open-connection (server-info) (interactive) (save-excursion - (let ((proc (socks-original-open-network-stream "socks" - nil - (nth 1 server-info) - (nth 2 server-info))) - (info (make-hash-table :size 13)) + (let ((proc + (let ((socks-override-functions nil)) + (open-network-stream "socks" + nil + (nth 1 server-info) + (nth 2 server-info)))) (authtype nil) version) ;; Initialize process and info about the process - (set-process-filter proc 'socks-filter) + (set-process-filter proc #'socks-filter) (set-process-query-on-exit-flag proc nil) - (puthash proc info socks-connections) - (puthash 'state socks-state-waiting-for-auth info) - (puthash 'authtype socks-authentication-failure info) - (puthash 'server-protocol (nth 3 server-info) info) - (puthash 'server-name (nth 1 server-info) info) + (process-put proc 'socks t) + (process-put proc 'socks-state socks-state-waiting-for-auth) + (process-put proc 'socks-authtype socks-authentication-failure) + (process-put proc 'socks-server-protocol (nth 3 server-info)) + (process-put proc 'socks-server-name (nth 1 server-info)) (setq version (nth 3 server-info)) (cond ((equal version 'http) @@ -393,15 +363,15 @@ version.") (socks-build-auth-list))) ;; Basically just do a select() until we change states. - (socks-wait-for-state-change proc info socks-state-waiting-for-auth) - (setq authtype (gethash 'authtype info)) + (socks-wait-for-state-change proc socks-state-waiting-for-auth) + (setq authtype (process-get proc 'socks-authtype)) (cond ((= authtype socks-authentication-null) (and socks-debug (message "No authentication necessary"))) ((= authtype socks-authentication-failure) (error "No acceptable authentication methods found")) (t - (let* ((auth-type (gethash 'authtype info)) + (let* ((auth-type (process-get proc 'socks-authtype)) (auth-handler (assoc auth-type socks-authentication-methods)) (auth-func (and auth-handler (cdr (cdr auth-handler)))) (auth-desc (and auth-handler (car (cdr auth-handler))))) @@ -415,8 +385,8 @@ version.") ) ) ) - (puthash 'state socks-state-authenticated info) - (set-process-filter proc 'socks-filter))) + (process-put proc 'socks-state socks-state-authenticated) + (set-process-filter proc #'socks-filter))) proc))) (defun socks-send-command (proc command atype address port) @@ -428,12 +398,11 @@ version.") (format "%c%s" (length address) address)) (t (error "Unknown address type: %d" atype)))) - (info (gethash proc socks-connections)) request version) - (or info (error "socks-send-command called on non-SOCKS connection %S" - proc)) - (puthash 'state socks-state-waiting info) - (setq version (gethash 'server-protocol info)) + (or (process-get proc 'socks) + (error "socks-send-command called on non-SOCKS connection %S" proc)) + (process-put proc 'socks-state socks-state-waiting) + (setq version (process-get proc 'socks-server-protocol)) (cond ((equal version 'http) (setq request (format (eval-when-compile @@ -447,38 +416,36 @@ version.") (error "Unsupported address type for HTTP: %d" atype))) port))) ((equal version 4) - (setq request (string-make-unibyte - (format - "%c%c%c%c%s%s%c" - version ; version - command ; command - (lsh port -8) ; port, high byte - (- port (lsh (lsh port -8) 8)) ; port, low byte - addr ; address - (user-full-name) ; username - 0 ; terminate username - )))) + (setq request (concat + (unibyte-string + version ; version + command ; command + (ash port -8) ; port, high byte + (logand port #xff)) ; port, low byte + addr ; address + (user-full-name) ; username + "\0"))) ; terminate username ((equal version 5) - (setq request (string-make-unibyte - (format - "%c%c%c%c%s%c%c" + (setq request (concat + (unibyte-string version ; version command ; command 0 ; reserved - atype ; address type - addr ; address - (lsh port -8) ; port, high byte - (- port (lsh (lsh port -8) 8)) ; port, low byte - )))) + atype) ; address type + addr ; address + (unibyte-string + (ash port -8) ; port, high byte + (logand port #xff))))) ; port, low byte (t (error "Unknown protocol version: %d" version))) (process-send-string proc request) - (socks-wait-for-state-change proc info socks-state-waiting) + (socks-wait-for-state-change proc socks-state-waiting) (process-status proc) - (if (= (or (gethash 'reply info) 1) socks-response-success) + (if (= (or (process-get proc 'socks-reply) 1) socks-response-success) nil ; Sweet sweet success! (delete-process proc) - (error "SOCKS: %s" (nth (or (gethash 'reply info) 1) socks-errors))) + (error "SOCKS: %s" + (nth (or (process-get proc 'socks-reply) 1) socks-errors))) proc)) @@ -486,7 +453,7 @@ version.") (defvar socks-noproxy nil "List of regexps matching hosts that we should not socksify connections to") -(defun socks-find-route (host service) +(defun socks-find-route (host _service) (let ((route socks-server) (noproxy socks-noproxy)) (while noproxy @@ -540,37 +507,46 @@ version.") (if udp socks-udp-services socks-tcp-services))) (defun socks-open-network-stream (name buffer host service) - (let* ((route (socks-find-route host service)) - proc info version atype) + (let ((socks-override-functions t)) + (socks--open-network-stream + (lambda (&rest args) + (let ((socks-override-functions nil)) + (apply #'open-network-stream args))) + name buffer host service))) + +(defun socks--open-network-stream (orig-fun name buffer host service &rest params) + (let ((route (and socks-override-functions + (socks-find-route host service)))) (if (not route) - (socks-original-open-network-stream name buffer host service) - (setq proc (socks-open-connection route) - info (gethash proc socks-connections) - version (gethash 'server-protocol info)) - (cond - ((equal version 4) - (setq host (socks-nslookup-host host)) - (if (not (listp host)) - (error "Could not get IP address for: %s" host)) - (setq host (apply 'format "%c%c%c%c" host)) - (setq atype socks-address-type-v4)) - (t - (setq atype socks-address-type-name))) - (socks-send-command proc - socks-connect-command - atype - host - (if (stringp service) - (or - (socks-find-services-entry service) - (error "Unknown service: %s" service)) - service)) - (puthash 'buffer buffer info) - (puthash 'host host info) - (puthash 'service host info) - (set-process-filter proc nil) - (set-process-buffer proc (if buffer (get-buffer-create buffer))) - proc))) + (apply orig-fun name buffer host service params) + ;; FIXME: Obey `params'! + (let* ((proc (socks-open-connection route)) + (version (process-get proc 'socks-server-protocol)) + (atype + (cond + ((equal version 4) + (setq host (socks-nslookup-host host)) + (if (not (listp host)) + (error "Could not get IP address for: %s" host)) + (setq host (apply #'format "%c%c%c%c" host)) + socks-address-type-v4) + (t + socks-address-type-name)))) + (socks-send-command proc + socks-connect-command + atype + host + (if (stringp service) + (or + (socks-find-services-entry service) + (error "Unknown service: %s" service)) + service)) + (process-put proc 'socks-buffer buffer) + (process-put proc 'socks-host host) + (process-put proc 'socks-service host) + (set-process-filter proc nil) + (set-process-buffer proc (if buffer (get-buffer-create buffer))) + proc)))) ;; Authentication modules go here @@ -581,24 +557,25 @@ version.") (defconst socks-username/password-auth-version 1) (defun socks-username/password-auth-filter (proc str) - (let ((info (gethash proc socks-connections))) - (or info (error "socks-filter called on non-SOCKS connection %S" proc)) - (puthash 'scratch (concat (gethash 'scratch info) str) info) - (if (< (length (gethash 'scratch info)) 2) - nil - (puthash 'password-auth-status (aref (gethash 'scratch info) 1) info) - (puthash 'state socks-state-authenticated info)))) + (or (process-get proc 'socks) + (error "socks-filter called on non-SOCKS connection %S" proc)) + (cl-callf (lambda (s) (concat s str)) + (process-get proc 'socks-scratch)) + (if (< (length (process-get proc 'socks-scratch)) 2) + nil + (process-put proc 'socks-password-auth-status + (aref (process-get proc 'socks-scratch) 1)) + (process-put proc 'socks-state socks-state-authenticated))) (defun socks-username/password-auth (proc) - (let* ((info (gethash proc socks-connections)) - (state (gethash 'state info))) + (let ((state (process-get proc 'socks-state))) (if (not socks-password) (setq socks-password (read-passwd (format "Password for %s@%s: " socks-username - (gethash 'server-name info))))) - (puthash 'scratch "" info) - (set-process-filter proc 'socks-username/password-auth-filter) + (process-get proc 'socks-server-name))))) + (process-put proc 'socks-scratch "") + (set-process-filter proc #'socks-username/password-auth-filter) (process-send-string proc (format "%c%c%s%c%s" socks-username/password-auth-version @@ -606,33 +583,32 @@ version.") socks-username (length socks-password) socks-password)) - (socks-wait-for-state-change proc info state) - (= (gethash 'password-auth-status info) 0))) + (socks-wait-for-state-change proc state) + (= (process-get proc 'socks-password-auth-status) 0))) ;; More advanced GSS/API stuff, not yet implemented - volunteers? ;; (socks-register-authentication-method 1 "GSS/API" 'socks-gssapi-auth) -(defun socks-gssapi-auth (proc) +(defun socks-gssapi-auth (_proc) nil) ;; CHAP stuff ;; (socks-register-authentication-method 3 "CHAP" 'socks-chap-auth) -(defun socks-chap-auth (proc) +(defun socks-chap-auth (_proc) nil) ;; CRAM stuff ;; (socks-register-authentication-method 5 "CRAM" 'socks-cram-auth) -(defun socks-cram-auth (proc) +(defun socks-cram-auth (_proc) nil) (defcustom socks-nslookup-program "nslookup" - "If non-NIL then a string naming the nslookup program." - :type '(choice (const :tag "None" :value nil) string) - :group 'socks) + "If non-nil then a string naming the nslookup program." + :type '(choice (const :tag "None" :value nil) string)) (defun socks-nslookup-host (host) "Attempt to resolve the given HOSTNAME using nslookup if possible." @@ -651,8 +627,8 @@ version.") (progn (setq res (buffer-substring (match-beginning 2) (match-end 2)) - res (mapcar 'string-to-number - (socks-split-string res "\\."))))) + res (mapcar #'string-to-number + (split-string res "\\."))))) (kill-buffer (current-buffer))) res) host)) diff --git a/lisp/net/starttls.el b/lisp/net/starttls.el deleted file mode 100644 index e2dff2d53d6..00000000000 --- a/lisp/net/starttls.el +++ /dev/null @@ -1,304 +0,0 @@ -;;; starttls.el --- STARTTLS functions - -;; Copyright (C) 1999-2018 Free Software Foundation, Inc. - -;; Author: Daiki Ueno <ueno@unixuser.org> -;; Author: Simon Josefsson <simon@josefsson.org> -;; Created: 1999/11/20 -;; Keywords: TLS, SSL, OpenSSL, GnuTLS, mail, news - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This module defines some utility functions for STARTTLS profiles. - -;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP" -;; by Chris Newman <chris.newman@innosoft.com> (1999/06) - -;; This file now contains a combination of the two previous -;; implementations both called "starttls.el". The first one is Daiki -;; Ueno's starttls.el which uses his own "starttls" command line tool, -;; and the second one is Simon Josefsson's starttls.el which uses -;; "gnutls-cli" from GnuTLS. -;; -;; If "starttls" is available, it is preferred by the code over -;; "gnutls-cli", for backwards compatibility. Use -;; `starttls-use-gnutls' to toggle between implementations if you have -;; both tools installed. It is recommended to use GnuTLS, though, as -;; it performs more verification of the certificates. - -;; The GnuTLS support requires GnuTLS 0.9.90 (released 2003-10-08) or -;; later, from <https://www.gnu.org/software/gnutls/>, or "starttls" -;; from <ftp://ftp.opaopa.org/pub/elisp/>. - -;; Usage is similar to `open-network-stream'. For example: -;; -;; (when (setq tmp (starttls-open-stream -;; "test" (current-buffer) "yxa.extundo.com" 25)) -;; (accept-process-output tmp 15) -;; (process-send-string tmp "STARTTLS\n") -;; (accept-process-output tmp 15) -;; (message "STARTTLS output:\n%s" (starttls-negotiate tmp)) -;; (process-send-string tmp "EHLO foo\n")) - -;; An example run yields the following output: -;; -;; 220 yxa.extundo.com ESMTP Sendmail 8.12.11/8.12.11/Debian-3; Wed, 26 May 2004 19:12:29 +0200; (No UCE/UBE) logging access from: c494102a.s-bi.bostream.se(OK)-c494102a.s-bi.bostream.se [217.215.27.65] -;; 220 2.0.0 Ready to start TLS -;; 250-yxa.extundo.com Hello c494102a.s-bi.bostream.se [217.215.27.65], pleased to meet you -;; 250-ENHANCEDSTATUSCODES -;; 250-PIPELINING -;; 250-EXPN -;; 250-VERB -;; 250-8BITMIME -;; 250-SIZE -;; 250-DSN -;; 250-ETRN -;; 250-AUTH DIGEST-MD5 CRAM-MD5 PLAIN LOGIN -;; 250-DELIVERBY -;; 250 HELP -;; nil -;; -;; With the message buffer containing: -;; -;; STARTTLS output: -;; *** Starting TLS handshake -;; - Server's trusted authorities: -;; [0]: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; - Certificate type: X.509 -;; - Got a certificate list of 2 certificates. -;; -;; - Certificate[0] info: -;; # The hostname in the certificate matches 'yxa.extundo.com'. -;; # valid since: Wed May 26 12:16:00 CEST 2004 -;; # expires at: Wed Jul 26 12:16:00 CEST 2023 -;; # serial number: 04 -;; # fingerprint: 7c 04 4b c1 fa 26 9b 5d 90 22 52 3c 65 3d 85 3a -;; # version: #1 -;; # public key algorithm: RSA -;; # Modulus: 1024 bits -;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=Mail server,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; -;; - Certificate[1] info: -;; # valid since: Sun May 23 11:35:00 CEST 2004 -;; # expires at: Sun Jul 23 11:35:00 CEST 2023 -;; # serial number: 00 -;; # fingerprint: fc 76 d8 63 1a c9 0b 3b fa 40 fe ed 47 7a 58 ae -;; # version: #3 -;; # public key algorithm: RSA -;; # Modulus: 1024 bits -;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; -;; - Peer's certificate issuer is unknown -;; - Peer's certificate is NOT trusted -;; - Version: TLS 1.0 -;; - Key Exchange: RSA -;; - Cipher: ARCFOUR 128 -;; - MAC: SHA -;; - Compression: NULL - -;;; Code: - -(defgroup starttls nil - "Support for `Transport Layer Security' protocol." - :version "21.1" - :group 'mail) - -(defcustom starttls-gnutls-program "gnutls-cli" - "Name of GnuTLS command line tool. -This program is used when GnuTLS is used, i.e. when -`starttls-use-gnutls' is non-nil." - :version "22.1" - :type 'string - :group 'starttls) - -(defcustom starttls-program "starttls" - "The program to run in a subprocess to open an TLSv1 connection. -This program is used when the `starttls' command is used, -i.e. when `starttls-use-gnutls' is nil." - :type 'string - :group 'starttls) - -(defcustom starttls-use-gnutls (not (executable-find starttls-program)) - "Whether to use GnuTLS instead of the `starttls' command." - :version "22.1" - :type 'boolean - :group 'starttls) - -(defcustom starttls-extra-args nil - "Extra arguments to `starttls-program'. -These apply when the `starttls' command is used, i.e. when -`starttls-use-gnutls' is nil." - :type '(repeat string) - :group 'starttls) - -(defcustom starttls-extra-arguments nil - "Extra arguments to `starttls-gnutls-program'. -These apply when GnuTLS is used, i.e. when `starttls-use-gnutls' is non-nil. - -For example, non-TLS compliant servers may require -\(\"--protocols\" \"ssl3\"). Invoke \"gnutls-cli --help\" to -find out which parameters are available." - :version "22.1" - :type '(repeat string) - :group 'starttls) - -(defcustom starttls-process-connection-type nil - "Value for `process-connection-type' to use when starting STARTTLS process." - :version "22.1" - :type 'boolean - :group 'starttls) - -(defcustom starttls-connect "- Simple Client Mode:\n\n" - "Regular expression indicating successful connection. -The default is what GnuTLS's \"gnutls-cli\" outputs." - ;; GnuTLS cli.c:main() prints this string when it is starting to run - ;; in the application read/write phase. If the logic, or the string - ;; itself, is modified, this must be updated. - :version "22.1" - :type 'regexp - :group 'starttls) - -(defcustom starttls-failure "\\*\\*\\* Handshake has failed" - "Regular expression indicating failed TLS handshake. -The default is what GnuTLS's \"gnutls-cli\" outputs." - ;; GnuTLS cli.c:do_handshake() prints this string on failure. If the - ;; logic, or the string itself, is modified, this must be updated. - :version "22.1" - :type 'regexp - :group 'starttls) - -(defcustom starttls-success "- Compression: " - "Regular expression indicating completed TLS handshakes. -The default is what GnuTLS's \"gnutls-cli\" outputs." - ;; GnuTLS cli.c:do_handshake() calls, on success, - ;; common.c:print_info(), that unconditionally print this string - ;; last. If that logic, or the string itself, is modified, this - ;; must be updated. - :version "22.1" - :type 'regexp - :group 'starttls) - -(defun starttls-negotiate-gnutls (process) - "Negotiate TLS on PROCESS opened by `open-starttls-stream'. -This should typically only be done once. It typically returns a -multi-line informational message with information about the -handshake, or nil on failure." - (let (buffer info old-max done-ok done-bad) - (if (null (setq buffer (process-buffer process))) - ;; XXX How to remove/extract the TLS negotiation junk? - (signal-process (process-id process) 'SIGALRM) - (with-current-buffer buffer - (save-excursion - (setq old-max (goto-char (point-max))) - (signal-process (process-id process) 'SIGALRM) - (while (and (processp process) - (eq (process-status process) 'run) - (save-excursion - (goto-char old-max) - (not (or (setq done-ok (re-search-forward - starttls-success nil t)) - (setq done-bad (re-search-forward - starttls-failure nil t)))))) - (accept-process-output process 1 100) - (sit-for 0.1)) - (setq info (buffer-substring-no-properties old-max (point-max))) - (delete-region old-max (point-max)) - (if (or (and done-ok (not done-bad)) - ;; Prevent mitm that fake success msg after failure msg. - (and done-ok done-bad (< done-ok done-bad))) - info - (message "STARTTLS negotiation failed: %s" info) - nil)))))) - -(defun starttls-negotiate (process) - (if starttls-use-gnutls - (starttls-negotiate-gnutls process) - (signal-process (process-id process) 'SIGALRM))) - -(defun starttls-open-stream-gnutls (name buffer host port) - (message "Opening STARTTLS connection to `%s:%s'..." host port) - (let* (done - (old-max (with-current-buffer buffer (point-max))) - (process-connection-type starttls-process-connection-type) - (process (apply #'start-process name buffer - starttls-gnutls-program "-s" host - "-p" (if (integerp port) - (int-to-string port) - port) - starttls-extra-arguments))) - (set-process-query-on-exit-flag process nil) - (while (and (processp process) - (eq (process-status process) 'run) - (with-current-buffer buffer - (goto-char old-max) - (not (setq done (re-search-forward - starttls-connect nil t))))) - (accept-process-output process 0 100) - (sit-for 0.1)) - (if done - (with-current-buffer buffer - (delete-region old-max done)) - (delete-process process) - (setq process nil)) - (message "Opening STARTTLS connection to `%s:%s'...%s" - host port (if done "done" "failed")) - process)) - -;;;###autoload -(defun starttls-open-stream (name buffer host port) - "Open a TLS connection for a port to a host. -Returns a subprocess object to represent the connection. -Input and output work as for subprocesses; `delete-process' closes it. -Args are NAME BUFFER HOST PORT. -NAME is name for process. It is modified if necessary to make it unique. -BUFFER is the buffer (or `buffer-name') to associate with the process. - Process output goes at end of that buffer, unless you specify - a filter function to handle the output. - BUFFER may be also nil, meaning that this process is not associated - with any buffer -Third arg is name of the host to connect to, or its IP address. -Fourth arg PORT is an integer specifying a port to connect to. -If `starttls-use-gnutls' is nil, this may also be a service name, but -GnuTLS requires a port number." - (if starttls-use-gnutls - (starttls-open-stream-gnutls name buffer host port) - (message "Opening STARTTLS connection to `%s:%s'" host (format "%s" port)) - (let* ((process-connection-type starttls-process-connection-type) - (process (apply #'start-process - name buffer starttls-program - host (format "%s" port) - starttls-extra-args))) - (set-process-query-on-exit-flag process nil) - process))) - -(defun starttls-available-p () - "Say whether the STARTTLS programs are available." - (and (not (memq system-type '(windows-nt ms-dos))) - (executable-find (if starttls-use-gnutls - starttls-gnutls-program - starttls-program)))) - -(defalias 'starttls-any-program-available 'starttls-available-p) -(make-obsolete 'starttls-any-program-available 'starttls-available-p - "2011-08-02") - -(provide 'starttls) - -;;; starttls.el ends here diff --git a/lisp/net/tls.el b/lisp/net/tls.el deleted file mode 100644 index b02a2654d41..00000000000 --- a/lisp/net/tls.el +++ /dev/null @@ -1,301 +0,0 @@ -;;; tls.el --- TLS/SSL support via wrapper around GnuTLS - -;; Copyright (C) 1996-1999, 2002-2018 Free Software Foundation, Inc. - -;; Author: Simon Josefsson <simon@josefsson.org> -;; Keywords: comm, tls, gnutls, ssl - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This package implements a simple wrapper around "gnutls-cli" to -;; make Emacs support TLS/SSL. -;; -;; Usage is the same as `open-network-stream', i.e.: -;; -;; (setq tmp (open-tls-stream "test" (current-buffer) "news.mozilla.org" 563)) -;; ... -;; #<process test> -;; (process-send-string tmp "mode reader\n") -;; 200 secnews.netscape.com Netscape-Collabra/3.52 03615 NNRP ready ... -;; nil -;; (process-send-string tmp "quit\n") -;; 205 -;; nil - -;; To use this package as a replacement for ssl.el by William M. Perry -;; <wmperry@cs.indiana.edu>, you need to evaluate the following: -;; -;; (defalias 'open-ssl-stream 'open-tls-stream) - -;;; Code: - -(require 'gnutls) - -(autoload 'format-spec "format-spec") -(autoload 'format-spec-make "format-spec") - -(defgroup tls nil - "Transport Layer Security (TLS) parameters." - :group 'comm) - -(defcustom tls-end-of-info - (concat - "\\(" - ;; `openssl s_client' regexp. See ssl/ssl_txt.c lines 219-220. - ;; According to apps/s_client.c line 1515 `---' is always the last - ;; line that is printed by s_client before the real data. - "^ Verify return code: .+\n---\n\\|" - ;; `gnutls' regexp. See src/cli.c lines 721-. - "^- Simple Client Mode:\n" - "\\(\n\\|" ; ignore blank lines - ;; According to GnuTLS v2.1.5 src/cli.c lines 640-650 and 705-715 - ;; in `main' the handshake will start after this message. If the - ;; handshake fails, the programs will abort. - "^\\*\\*\\* Starting TLS handshake\n\\)*" - "\\)") - "Regexp matching end of TLS client informational messages. -Client data stream begins after the last character this matches. -The default matches the output of \"gnutls-cli\" (version 2.0.1)." - :version "22.2" - :type 'regexp - :group 'tls) - -(defcustom tls-program - '("gnutls-cli --x509cafile %t -p %p %h" - "gnutls-cli --x509cafile %t -p %p %h --protocols ssl3") - "List of strings containing commands to start TLS stream to a host. -Each entry in the list is tried until a connection is successful. -%h is replaced with the server hostname, %p with the port to -connect to, and %t with a file name containing trusted certificates. -The program should read input on stdin and write output to stdout. - -See `tls-checktrust' on how to check trusted root certs. - -Also see `tls-success' for what the program should output after -successful negotiation." - :type - '(choice - (const :tag "Default list of commands" - ("gnutls-cli --x509cafile %t -p %p %h" - "gnutls-cli --x509cafile %t -p %p %h --protocols ssl3")) - (list :tag "Choose commands" - :value - ("gnutls-cli --x509cafile %t -p %p %h" - "gnutls-cli --x509cafile %t -p %p %h --protocols ssl3") - (set :inline t - ;; FIXME: add brief `:tag "..."' descriptions. - ;; (repeat :inline t :tag "Other" (string)) - ;; No trust check: - (const "gnutls-cli --insecure -p %p %h") - (const "gnutls-cli --insecure -p %p %h --protocols ssl3")) - (repeat :inline t :tag "Other" (string))) - (list :tag "List of commands" - (repeat :tag "Command" (string)))) - :version "26.1" ; remove s_client - :group 'tls) - -(defcustom tls-process-connection-type nil - "Value for `process-connection-type' to use when starting TLS process." - :version "22.1" - :type 'boolean - :group 'tls) - -(defcustom tls-success "- Handshake was completed\\|SSL handshake has read " - "Regular expression indicating completed TLS handshakes. -The default is what GnuTLS's \"gnutls-cli\" outputs." -;; or OpenSSL's \"openssl s_client\" - :version "22.1" - :type 'regexp - :group 'tls) - -(defcustom tls-checktrust nil - "Indicate if certificates should be checked against trusted root certs. -If this is `ask', the user can decide whether to accept an -untrusted certificate. You may have to adapt `tls-program' in -order to make this feature work properly, i.e., to ensure that -the external program knows about the root certificates you -consider trustworthy, e.g.: - -\(setq tls-program - \\='(\"gnutls-cli --x509cafile /etc/ssl/certs/ca-certificates.crt -p %p %h\" - \"gnutls-cli --x509cafile /etc/ssl/certs/ca-certificates.crt -p %p %h --protocols ssl3\"))" - :type '(choice (const :tag "Always" t) - (const :tag "Never" nil) - (const :tag "Ask" ask)) - :version "23.1" ;; No Gnus - :group 'tls) - -(defcustom tls-untrusted - "- Peer's certificate is NOT trusted\\|Verify return code: \\([^0] \\|.[^ ]\\)" - "Regular expression indicating failure of TLS certificate verification. -The default is what GnuTLS's \"gnutls-cli\" returns in the event of -unsuccessful verification." -;; or OpenSSL's \"openssl s_client\" - :type 'regexp - :version "23.1" ;; No Gnus - :group 'tls) - -(defcustom tls-hostmismatch - "# The hostname in the certificate does NOT match" - "Regular expression indicating a host name mismatch in certificate. -When the host name specified in the certificate doesn't match the -name of the host you are connecting to, gnutls-cli issues a -warning to this effect. There is no such feature in openssl. Set -this to nil if you want to ignore host name mismatches." - :type 'regexp - :version "23.1" ;; No Gnus - :group 'tls) - -(defcustom tls-certtool-program "certtool" - "Name of GnuTLS certtool. -Used by `tls-certificate-information'." - :version "22.1" - :type 'string - :group 'tls) - -(defalias 'tls-format-message - (if (fboundp 'format-message) 'format-message - ;; for Emacs < 25, and XEmacs, don't worry about quote translation. - 'format)) - -(defun tls-certificate-information (der) - "Parse X.509 certificate in DER format into an assoc list." - (let ((certificate (concat "-----BEGIN CERTIFICATE-----\n" - (base64-encode-string der) - "\n-----END CERTIFICATE-----\n")) - (exit-code 0)) - (with-current-buffer (get-buffer-create " *certtool*") - (erase-buffer) - (insert certificate) - (setq exit-code (condition-case () - (call-process-region (point-min) (point-max) - tls-certtool-program - t (list (current-buffer) nil) t - "--certificate-info") - (error -1))) - (if (/= exit-code 0) - nil - (let ((vals nil)) - (goto-char (point-min)) - (while (re-search-forward "^\\([^:]+\\): \\(.*\\)" nil t) - (push (cons (match-string 1) (match-string 2)) vals)) - (nreverse vals)))))) - -(defun open-tls-stream (name buffer host port) - "Open a TLS connection for a port to a host. -Returns a subprocess-object to represent the connection. -Input and output work as for subprocesses; `delete-process' closes it. -Args are NAME BUFFER HOST PORT. -NAME is name for process. It is modified if necessary to make it unique. -BUFFER is the buffer (or buffer name) to associate with the process. - Process output goes at end of that buffer, unless you specify - a filter function to handle the output. - BUFFER may be also nil, meaning that this process is not associated - with any buffer -Third arg is name of the host to connect to, or its IP address. -Fourth arg PORT is an integer specifying a port to connect to." - (let ((cmds tls-program) - (use-temp-buffer (null buffer)) - process cmd done) - (if use-temp-buffer - (setq buffer (generate-new-buffer " TLS")) - ;; BUFFER is a string but does not exist as a buffer object. - (unless (and (get-buffer buffer) - (buffer-name (get-buffer buffer))) - (generate-new-buffer buffer))) - (with-current-buffer buffer - (message "Opening TLS connection to `%s'..." host) - (while (and (not done) (setq cmd (pop cmds))) - (let ((process-connection-type tls-process-connection-type) - (formatted-cmd - (format-spec - cmd - (format-spec-make - ?t (car (gnutls-trustfiles)) - ?h host - ?p (if (integerp port) - (int-to-string port) - port))))) - (message "Opening TLS connection with `%s'..." formatted-cmd) - (setq process (start-process - name buffer shell-file-name shell-command-switch - formatted-cmd)) - (while (and process - (memq (process-status process) '(open run)) - (progn - (goto-char (point-min)) - (not (setq done (re-search-forward - tls-success nil t))))) - (unless (accept-process-output process 1) - (sit-for 1))) - (message "Opening TLS connection with `%s'...%s" formatted-cmd - (if done "done" "failed")) - (if (not done) - (delete-process process) - ;; advance point to after all informational messages that - ;; `openssl s_client' and `gnutls' print - (let ((start-of-data nil)) - (while - (not (setq start-of-data - ;; the string matching `tls-end-of-info' - ;; might come in separate chunks from - ;; `accept-process-output', so start the - ;; search where `tls-success' ended - (save-excursion - (if (re-search-forward tls-end-of-info nil t) - (match-end 0))))) - (accept-process-output process 1)) - (if start-of-data - ;; move point to start of client data - (goto-char start-of-data))) - (setq done process)))) - (when (and done - (or - (and tls-checktrust - (save-excursion - (goto-char (point-min)) - (re-search-forward tls-untrusted nil t)) - (or - (and (not (eq tls-checktrust 'ask)) - (message "The certificate presented by `%s' is \ -NOT trusted." host)) - (not (yes-or-no-p - (tls-format-message "\ -The certificate presented by `%s' is NOT trusted. Accept anyway? " host))))) - (and tls-hostmismatch - (save-excursion - (goto-char (point-min)) - (re-search-forward tls-hostmismatch nil t)) - (not (yes-or-no-p - (format "Host name in certificate doesn't \ -match `%s'. Connect anyway? " host)))))) - (setq done nil) - (delete-process process)) - ;; Delete all the informational messages that could confuse - ;; future uses of `buffer'. - (delete-region (point-min) (point))) - (message "Opening TLS connection to `%s'...%s" - host (if done "done" "failed")) - (when use-temp-buffer - (if done (set-process-buffer process nil)) - (kill-buffer buffer)) - done)) - -(provide 'tls) - -;;; tls.el ends here diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 0576cbe9636..7906ec9f7cf 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -68,7 +68,7 @@ It is used for TCP/IP devices." (defconst tramp-adb-ls-toolbox-regexp (concat - "^[[:space:]]*\\([-[:alpha:]]+\\)" ; \1 permissions + "^[[:space:]]*\\([-.[:alpha:]]+\\)" ; \1 permissions "\\(?:[[:space:]]+[[:digit:]]+\\)?" ; links (Android 7/toybox) "[[:space:]]*\\([^[:space:]]+\\)" ; \2 username "[[:space:]]+\\([^[:space:]]+\\)" ; \3 group @@ -107,11 +107,12 @@ It is used for TCP/IP devices." . tramp-adb-handle-directory-files-and-attributes) (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) - (expand-file-name . tramp-adb-handle-expand-file-name) + (exec-path . tramp-adb-handle-exec-path) + (expand-file-name . tramp-handle-expand-file-name) (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . ignore) (file-attributes . tramp-adb-handle-file-attributes) - (file-directory-p . tramp-adb-handle-file-directory-p) + (file-directory-p . tramp-handle-file-directory-p) (file-equal-p . tramp-handle-file-equal-p) ;; FIXME: This is too sloppy. (file-executable-p . tramp-handle-file-exists-p) @@ -140,7 +141,6 @@ It is used for TCP/IP devices." (file-truename . tramp-adb-handle-file-truename) (file-writable-p . tramp-adb-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) - ;; `find-file-noselect' performed by default handler. ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) @@ -172,8 +172,9 @@ It is used for TCP/IP devices." ;;;###tramp-autoload (defsubst tramp-adb-file-name-p (filename) "Check if it's a filename for ADB." - (let ((v (tramp-dissect-file-name filename))) - (string= (tramp-file-name-method v) tramp-adb-method))) + (and (tramp-tramp-file-p filename) + (string= (tramp-file-name-method (tramp-dissect-file-name filename)) + tramp-adb-method))) ;;;###tramp-autoload (defun tramp-adb-file-name-handler (operation &rest args) @@ -196,11 +197,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) @@ -223,36 +226,6 @@ pass to the OPERATION." result) result)))) -(defun tramp-adb-handle-expand-file-name (name &optional dir) - "Like `expand-file-name' for Tramp files." - ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". - (setq dir (or dir default-directory "/")) - ;; Unless NAME is absolute, concat DIR and NAME. - (unless (file-name-absolute-p name) - (setq name (concat (file-name-as-directory dir) name))) - ;; If NAME is not a Tramp file, run the real handler. - (if (not (tramp-tramp-file-p name)) - (tramp-run-real-handler 'expand-file-name (list name nil)) - ;; Dissect NAME. - (with-parsed-tramp-file-name name nil - (unless (tramp-run-real-handler 'file-name-absolute-p (list localname)) - (setq localname (concat "/" localname))) - ;; Do normal `expand-file-name' (this does "/./" and "/../"). - ;; `default-directory' is bound, because on Windows there would - ;; be problems with UNC shares or Cygwin mounts. - (let ((default-directory (tramp-compat-temporary-file-directory))) - (tramp-make-tramp-file-name - method user domain host port - (tramp-drop-volume-letter - (tramp-run-real-handler - 'expand-file-name (list localname)))))))) - -(defun tramp-adb-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - (eq (tramp-compat-file-attribute-type - (file-attributes (file-truename filename))) - t)) - (defun tramp-adb-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." (ignore-errors @@ -264,18 +237,19 @@ pass to the OPERATION." (goto-char (point-min)) (forward-line) (when (looking-at - (concat "[[:space:]]*[^[:space:]]+" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)")) + (eval-when-compile + (concat "[[:space:]]*[^[:space:]]+" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)"))) ;; The values are given as 1k numbers, so we must change ;; them to number of bytes. - (list (* 1024 (string-to-number (concat (match-string 1) "e0"))) + (list (* 1024 (string-to-number (match-string 1))) ;; The second value is the used size. We need the ;; free size. - (* 1024 (- (string-to-number (concat (match-string 1) "e0")) - (string-to-number (concat (match-string 2) "e0")))) - (* 1024 (string-to-number (concat (match-string 3) "e0"))))))))) + (* 1024 (- (string-to-number (match-string 1)) + (string-to-number (match-string 2)))) + (* 1024 (string-to-number (match-string 3))))))))) ;; This is derived from `tramp-sh-handle-file-truename'. Maybe the ;; code could be shared? @@ -287,7 +261,7 @@ pass to the OPERATION." 'file-name-as-directory 'identity) (with-parsed-tramp-file-name (expand-file-name filename) nil (tramp-make-tramp-file-name - method user domain host port + v (with-tramp-file-property v localname "file-truename" (let ((result nil) ; result steps in reverse order (quoted (tramp-compat-file-name-quoted-p localname))) @@ -316,12 +290,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) @@ -418,9 +390,9 @@ pass to the OPERATION." ;; no way to handle numeric ids in Androids ash (if (eq id-format 'integer) 0 uid) (if (eq id-format 'integer) 0 gid) - '(0 0) ; atime + tramp-time-dont-know ; atime (date-to-time date) ; mtime - '(0 0) ; ctime + tramp-time-dont-know ; ctime size mod-string ;; fake @@ -469,18 +441,24 @@ pass to the OPERATION." (sort result (lambda (x y) (string< (car x) (car y)))))) (delq nil (mapcar (lambda (x) - (if (or (not match) (string-match match (car x))) + (if (or (not match) (string-match-p match (car x))) x)) result))))))))) (defun tramp-adb-get-ls-command (vec) - "Determine `ls' command at its arguments." + "Determine `ls' command and its arguments." (with-tramp-connection-property vec "ls" (tramp-message vec 5 "Finding a suitable `ls' command") (cond + ;; Support Android derived systems where "ls" command is provided + ;; by GNU Coreutils. Force "ls" to print one column and set + ;; time-style to imitate other "ls" flavors. + ((tramp-adb-send-command-and-check + vec "ls --time-style=long-iso /dev/null") + "ls -1 --time-style=long-iso") ;; Can't disable coloring explicitly for toybox ls command. We - ;; must force "ls" to print just one column. - ((tramp-adb-send-command-and-check vec "toybox") "env COLUMNS=1 ls") + ;; also must force "ls" to print just one column. + ((tramp-adb-send-command-and-check vec "toybox") "ls -1") ;; On CyanogenMod based system BusyBox is used and "ls" output ;; coloring is enabled by default. So we try to disable it when ;; possible. @@ -500,7 +478,7 @@ Convert (\"-al\") to (\"-a\" \"-l\"). Remove arguments like \"--dired\"." (delq nil (mapcar (lambda (s) - (and (not (string-match "\\(^--\\|^[^-]\\)" s)) s)) + (and (not (string-match-p "\\(^--\\|^[^-]\\)" s)) s)) switches)))))) (defun tramp-adb-sh-fix-ls-output (&optional sort-by-time) @@ -515,7 +493,7 @@ Emacs dired can't find files." "[[:space:]]\\([[:space:]][0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9][[:space:]]\\)" nil t) (replace-match "0\\1" "\\1" nil) ;; Insert missing "/". - (when (looking-at "[0-9][0-9]:[0-9][0-9][[:space:]]+$") + (when (looking-at-p "[0-9][0-9]:[0-9][0-9][[:space:]]+$") (end-of-line) (insert "/"))) ;; Sort entries. @@ -557,8 +535,8 @@ Emacs dired can't find files." (let ((par (expand-file-name ".." dir))) (unless (file-directory-p par) (make-directory par parents)))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (unless (or (tramp-adb-send-command-and-check v (format "mkdir %s" (tramp-shell-quote-argument localname))) (and parents (file-directory-p dir))) @@ -568,11 +546,11 @@ Emacs dired can't find files." "Like `delete-directory' for Tramp files." (setq directory (expand-file-name directory)) (with-parsed-tramp-file-name (file-truename directory) nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname)) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname)) (with-parsed-tramp-file-name directory nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (tramp-adb-barf-unless-okay v (format "%s %s" (if recursive "rm -r" "rmdir") @@ -583,8 +561,8 @@ Emacs dired can't find files." "Like `delete-file' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (tramp-adb-barf-unless-okay v (format "rm %s" (tramp-shell-quote-argument localname)) "Couldn't delete %s" filename))) @@ -595,28 +573,27 @@ Emacs dired can't find files." filename (with-parsed-tramp-file-name (expand-file-name directory) nil (with-tramp-file-property v localname "file-name-all-completions" - (save-match-data - (tramp-adb-send-command - v (format "%s -a %s" - (tramp-adb-get-ls-command v) - (tramp-shell-quote-argument localname))) - (mapcar - (lambda (f) - (if (file-directory-p (expand-file-name f directory)) - (file-name-as-directory f) - f)) - (with-current-buffer (tramp-get-buffer v) - (delete-dups - (append - ;; In older Android versions, "." and ".." are not - ;; included. In newer versions (toybox, since Android - ;; 6) they are. We fix this by `delete-dups'. - '("." "..") - (delq - nil - (mapcar - (lambda (l) (and (not (string-match "^[[:space:]]*$" l)) l)) - (split-string (buffer-string) "\n")))))))))))) + (tramp-adb-send-command + v (format "%s -a %s" + (tramp-adb-get-ls-command v) + (tramp-shell-quote-argument localname))) + (mapcar + (lambda (f) + (if (file-directory-p (expand-file-name f directory)) + (file-name-as-directory f) + f)) + (with-current-buffer (tramp-get-buffer v) + (delete-dups + (append + ;; In older Android versions, "." and ".." are not + ;; included. In newer versions (toybox, since Android 6) + ;; they are. We fix this by `delete-dups'. + '("." "..") + (delq + nil + (mapcar + (lambda (l) (and (not (string-match-p "^[[:space:]]*$" l)) l)) + (split-string (buffer-string) "\n"))))))))))) (defun tramp-adb-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." @@ -641,7 +618,7 @@ Emacs dired can't find files." tmpfile))) (defun tramp-adb-handle-file-writable-p (filename) - "Like `tramp-sh-handle-file-writable-p'. + "Like `file-writable-p' for Tramp files. But handle the case, if the \"test\" command is not available." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-writable-p" @@ -677,8 +654,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)) @@ -717,16 +694,18 @@ But handle the case, if the \"test\" command is not available." (defun tramp-adb-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (tramp-adb-send-command-and-check v (format "chmod %o %s" mode localname)))) (defun tramp-adb-handle-set-file-times (filename &optional time) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) - (let ((time (if (or (null time) (equal time '(0 0))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (let ((time (if (or (null time) + (tramp-compat-time-equal-p time tramp-time-doesnt-exist) + (tramp-compat-time-equal-p time tramp-time-dont-know)) (current-time) time))) (tramp-adb-send-command-and-check @@ -753,16 +732,16 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." v 0 (format "Copying %s to %s" filename newname) (if (and t1 t2 (tramp-equal-remote filename newname)) - (let ((l1 (file-remote-p filename 'localname)) - (l2 (file-remote-p newname 'localname))) + (let ((l1 (tramp-compat-file-local-name filename)) + (l2 (tramp-compat-file-local-name newname))) (when (and (not ok-if-already-exists) (file-exists-p newname)) (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 l2)) - (tramp-flush-file-property v l2) + (tramp-flush-file-properties v (file-name-directory l2)) + (tramp-flush-file-properties v l2) ;; Short track. (tramp-adb-barf-unless-okay v (format @@ -796,8 +775,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) @@ -833,17 +813,17 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (if (and t1 t2 (tramp-equal-remote filename newname) (not (file-directory-p filename))) - (let ((l1 (file-remote-p filename 'localname)) - (l2 (file-remote-p newname 'localname))) + (let ((l1 (tramp-compat-file-local-name filename)) + (l2 (tramp-compat-file-local-name newname))) (when (and (not ok-if-already-exists) (file-exists-p newname)) (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 @@ -878,8 +858,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq input (with-parsed-tramp-file-name infile nil localname)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) - tmpinput (tramp-make-tramp-file-name - method user domain host port input)) + tmpinput (tramp-make-tramp-file-name v input)) (copy-file infile tmpinput t))) (when input (setq command (format "%s <%s" command input))) @@ -912,8 +891,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; stderr must be copied to remote host. The temporary ;; file must be deleted after execution. (setq stderr (tramp-make-tramp-temp-file v) - tmpstderr (tramp-make-tramp-file-name - method user domain host port stderr)))) + tmpstderr (tramp-make-tramp-file-name v stderr)))) ;; stderr to be discarded. ((null (cadr destination)) (setq stderr "/dev/null")))) @@ -957,7 +935,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) @@ -967,7 +945,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (defun tramp-adb-handle-shell-command (command &optional output-buffer error-buffer) "Like `shell-command' for Tramp files." - (let* ((asynchronous (string-match "[ \t]*&[ \t]*\\'" command)) + (let* ((asynchronous (string-match-p "[ \t]*&[ \t]*\\'" command)) ;; We cannot use `shell-file-name' and `shell-command-switch', ;; they are variables of the local host. (args (list "sh" "-c" (substring command 0 asynchronous))) @@ -999,7 +977,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when p (if (yes-or-no-p "A command is running. Kill it? ") (ignore-errors (kill-process p)) - (tramp-compat-user-error p "Shell command in progress"))) + (tramp-user-error p "Shell command in progress"))) (if current-buffer-p (progn @@ -1111,13 +1089,28 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." p)))) ;; Save exit. - (if (string-match tramp-temp-buffer-name (buffer-name)) + (if (string-match-p tramp-temp-buffer-name (buffer-name)) (ignore-errors (set-process-buffer (tramp-get-connection-process v) nil) (kill-buffer (current-buffer))) (set-buffer-modified-p bmp)) - (tramp-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-handle-exec-path () + "Like `exec-path' for Tramp files." + (append + (with-parsed-tramp-file-name default-directory nil + (with-tramp-connection-property v "remote-path" + (tramp-adb-send-command v "echo \\\"$PATH\\\"") + (split-string + (with-current-buffer (tramp-get-connection-buffer v) + ;; Read the expression. + (goto-char (point-min)) + (read (current-buffer))) + ":" 'omit))) + ;; The equivalent to `exec-directory'. + `(,(tramp-compat-file-local-name default-directory)))) (defun tramp-adb-get-device (vec) "Return full host name from VEC to be used in shell execution. @@ -1126,7 +1119,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)) @@ -1271,10 +1264,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. @@ -1304,7 +1293,7 @@ connection if a previous connection has died for some reason." (tramp-adb-wait-for-output p 30) (unless (process-live-p p) (tramp-error vec 'file-error "Terminated!")) - (tramp-set-connection-property p "vector" vec) + (process-put p 'vector vec) (process-put p 'adjust-window-size-function 'ignore) (set-process-query-on-exit-flag p nil) @@ -1343,22 +1332,10 @@ connection if a previous connection has died for some reason." (tramp-adb-send-command vec (format "su %s" user)) (unless (tramp-adb-send-command-and-check vec nil) (delete-process p) - (tramp-set-file-property vec "" "su-command-p" nil) + (tramp-flush-file-property vec "" "su-command-p") (tramp-error vec 'file-error "Cannot switch to user `%s'" user))) - ;; Set "remote-path" connection property. This is needed - ;; for eshell. - (tramp-adb-send-command vec "echo \\\"$PATH\\\"") - (tramp-set-connection-property - vec "remote-path" - (split-string - (with-current-buffer (tramp-get-connection-buffer vec) - ;; Read the expression. - (goto-char (point-min)) - (read (current-buffer))) - ":" 'omit)) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el new file mode 100644 index 00000000000..cb072ac720f --- /dev/null +++ b/lisp/net/tramp-archive.el @@ -0,0 +1,651 @@ +;;; tramp-archive.el --- Tramp archive manager -*- lexical-binding:t -*- + +;; Copyright (C) 2017-2018 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; Keywords: comm, processes +;; Package: tramp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Access functions for file archives. This is possible only on +;; machines which have installed the virtual file system for the Gnome +;; Desktop (GVFS). Internally, file archives are mounted via the GVFS +;; "archive" method. + +;; A file archive is a regular file of kind "/path/to/dir/file.EXT". +;; The extension ".EXT" identifies the type of the file archive. A +;; file inside a file archive, called archive file name, has the name +;; "/path/to/dir/file.EXT/dir/file". + +;; Most of the magic file name operations are implemented for archive +;; file names, exceptions are all operations which write into a file +;; archive, and process related operations. Therefore, functions like + +;; (copy-file "/path/to/dir/file.tar/dir/file" "/somewhere/else") + +;; work out of the box. This is also true for file name completion, +;; and for libraries like `dired' or `ediff', which accept archive +;; file names as well. + +;; File archives are identified by the file name extension ".EXT". +;; Since GVFS uses internally the library libarchive(3), all suffixes, +;; which are accepted by this library, work also for archive file +;; names. Accepted suffixes are listed in the constant +;; `tramp-archive-suffixes'. They are + +;; * ".7z" - 7-Zip archives +;; * ".apk" - Android package kits +;; * ".ar" - UNIX archiver formats +;; * ".cab", ".CAB" - Microsoft Windows cabinets +;; * ".cpio" - CPIO archives +;; * ".deb" - Debian packages +;; * ".depot" - HP-UX SD depots +;; * ".exe" - Self extracting Microsoft Windows EXE files +;; * ".iso" - ISO 9660 images +;; * ".jar" - Java archives +;; * ".lzh", ".LZH" - Microsoft Windows compressed LHA archives +;; * ".msu", ".MSU" - Microsoft Windows Update packages +;; * ".mtree" - BSD mtree format +;; * ".odb" ".odf" ".odg" ".odp" ".ods" ".odt" - OpenDocument formats +;; * ".pax" - Posix archives +;; * ".rar" - RAR archives +;; * ".rpm" - Red Hat packages +;; * ".shar" - Shell archives +;; * ".tar", ".tbz", ".tgz", ".tlz", ".txz" - (Compressed) tape archives +;; * ".warc" - Web archives +;; * ".xar" - macOS XAR archives +;; * ".xpi" - XPInstall Mozilla addons +;; * ".xps" - Open XML Paper Specification (OpenXPS) documents +;; * ".zip", ".ZIP" - ZIP archives + +;; File archives could also be compressed, identified by an additional +;; compression suffix. Valid compression suffixes are listed in the +;; constant `tramp-archive-compression-suffixes'. They are ".bz2", +;; ".gz", ".lrz", ".lz", ".lz4", ".lzma", ".lzo", ".uu", ".xz" and +;; ".Z". A valid archive file name would be +;; "/path/to/dir/file.tar.gz/dir/file". Even several suffixes in a +;; row are possible, like "/path/to/dir/file.tar.gz.uu/dir/file". + +;; An archive file name could be a remote file name, as in +;; "/ftp:anonymous@ftp.gnu.org:/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL". +;; Since all file operations are mapped internally to GVFS operations, +;; remote file names supported by tramp-gvfs.el perform better, +;; because no local copy of the file archive must be downloaded first. +;; For example, "/sftp:user@host:..." performs better than the similar +;; "/scp:user@host:...". See the constant +;; `tramp-archive-all-gvfs-methods' for a complete list of +;; tramp-gvfs.el supported method names. + +;; If `url-handler-mode' is enabled, archives could be visited via +;; URLs, like "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL". +;; This allows complex file operations like + +;; (ediff-directories +;; "https://ftp.gnu.org/gnu/tramp/tramp-2.3.1.tar.gz/tramp-2.3.1" +;; "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/tramp-2.3.2" "") + +;; It is even possible to access file archives in file archives, as + +;; (find-file +;; "http://ftp.debian.org/debian/pool/main/c/coreutils/coreutils_8.28-1_amd64.deb/control.tar.gz/control") + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'tramp-gvfs) + +(autoload 'dired-uncache "dired") +(autoload 'url-tramp-convert-url-to-tramp "url-tramp") +(defvar url-handler-mode-hook) +(defvar url-handler-regexp) +(defvar url-tramp-protocols) + +;; We cannot check `tramp-gvfs-enabled' in loaddefs.el, because this +;; would load Tramp. So we make a cheaper check. +;;;###autoload +(defvar tramp-archive-enabled (featurep 'dbusbind) + "Non-nil when file archive support is available.") + +;; After loading tramp-gvfs.el, we know it better. +(setq tramp-archive-enabled tramp-gvfs-enabled) + +;; <https://github.com/libarchive/libarchive/wiki/LibarchiveFormats> +;;;###autoload +(defconst tramp-archive-suffixes + ;; "cab", "lzh", "msu" and "zip" are included with lower and upper + ;; letters, because Microsoft Windows provides them often with + ;; capital letters. + '("7z" ;; 7-Zip archives. + "apk" ;; Android package kits. Not in libarchive testsuite. + "ar" ;; UNIX archiver formats. + "cab" "CAB" ;; Microsoft Windows cabinets. + "cpio" ;; CPIO archives. + "deb" ;; Debian packages. Not in libarchive testsuite. + "depot" ;; HP-UX SD depot. Not in libarchive testsuite. + "exe" ;; Self extracting Microsoft Windows EXE files. + "iso" ;; ISO 9660 images. + "jar" ;; Java archives. Not in libarchive testsuite. + "lzh" "LZH" ;; Microsoft Windows compressed LHA archives. + "msu" "MSU" ;; Microsoft Windows Update packages. Not in testsuite. + "mtree" ;; BSD mtree format. + "odb" "odf" "odg" "odp" "ods" "odt" ;; OpenDocument formats. Not in testsuite. + "pax" ;; Posix archives. + "rar" ;; RAR archives. + "rpm" ;; Red Hat packages. + "shar" ;; Shell archives. Not in libarchive testsuite. + "tar" "tbz" "tgz" "tlz" "txz" ;; (Compressed) tape archives. + "warc" ;; Web archives. + "xar" ;; macOS XAR archives. Not in libarchive testsuite. + "xpi" ;; XPInstall Mozilla addons. Not in libarchive testsuite. + "xps" ;; Open XML Paper Specification (OpenXPS) documents. + "zip" "ZIP") ;; ZIP archives. + "List of suffixes which indicate a file archive. +It must be supported by libarchive(3).") + +;; <http://unix-memo.readthedocs.io/en/latest/vfs.html> +;; read and write: tar, cpio, pax , gzip , zip, bzip2, xz, lzip, lzma, ar, mtree, iso9660, compress. +;; read only: 7-Zip, mtree, xar, lha/lzh, rar, microsoft cab. + +;;;###autoload +(defconst tramp-archive-compression-suffixes + '("bz2" "gz" "lrz" "lz" "lz4" "lzma" "lzo" "uu" "xz" "Z") + "List of suffixes which indicate a compressed file. +It must be supported by libarchive(3).") + +;; The definition of `tramp-archive-file-name-regexp' contains calls +;; to `regexp-opt', which cannot be autoloaded while loading +;; loaddefs.el. So we use a macro, which is evaluated only when needed. +;;;###autoload +(progn (defmacro tramp-archive-autoload-file-name-regexp () + "Regular expression matching archive file names." + '(concat + "\\`" "\\(" ".+" "\\." + ;; Default suffixes ... + (regexp-opt tramp-archive-suffixes) + ;; ... with compression. + "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*" + "\\)" ;; \1 + "\\(" "/" ".*" "\\)" "\\'"))) ;; \2 + +;; In older Emacsen (prior 27.1), `tramp-archive-autoload-file-name-regexp' +;; is not autoloaded. So we cannot expect it to be known in +;; tramp-loaddefs.el. But it exists, when tramp-archive.el is loaded. +;;;###tramp-autoload +(defconst tramp-archive-file-name-regexp + (ignore-errors (tramp-archive-autoload-file-name-regexp)) + "Regular expression matching archive file names.") + +;;;###tramp-autoload +(defconst tramp-archive-method "archive" + "Method name for archives in GVFS.") + +(defconst tramp-archive-all-gvfs-methods + (cons tramp-archive-method + (let ((values (cdr (cadr (get 'tramp-gvfs-methods 'custom-type))))) + (setq values (mapcar 'last values) + values (mapcar 'car values)))) + "List of all methods `tramp-gvfs-methods' offers.") + + +;; New handlers should be added here. +;;;###tramp-autoload +(defconst tramp-archive-file-name-handler-alist + '((access-file . ignore) + (add-name-to-file . tramp-archive-handle-not-implemented) + ;; `byte-compiler-base-file-name' performed by default handler. + ;; `copy-directory' performed by default handler. + (copy-file . tramp-archive-handle-copy-file) + (delete-directory . tramp-archive-handle-not-implemented) + (delete-file . tramp-archive-handle-not-implemented) + ;; `diff-latest-backup-file' performed by default handler. + (directory-file-name . tramp-archive-handle-directory-file-name) + (directory-files . tramp-handle-directory-files) + (directory-files-and-attributes + . tramp-handle-directory-files-and-attributes) + (dired-compress-file . tramp-archive-handle-not-implemented) + (dired-uncache . tramp-archive-handle-dired-uncache) + (exec-path . ignore) + ;; `expand-file-name' performed by default handler. + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) + (file-acl . ignore) + (file-attributes . tramp-archive-handle-file-attributes) + (file-directory-p . tramp-handle-file-directory-p) + (file-equal-p . tramp-handle-file-equal-p) + (file-executable-p . tramp-archive-handle-file-executable-p) + (file-exists-p . tramp-handle-file-exists-p) + (file-in-directory-p . tramp-handle-file-in-directory-p) + (file-local-copy . tramp-archive-handle-file-local-copy) + (file-modes . tramp-handle-file-modes) + (file-name-all-completions . tramp-archive-handle-file-name-all-completions) + ;; `file-name-as-directory' performed by default handler. + (file-name-case-insensitive-p . ignore) + (file-name-completion . tramp-handle-file-name-completion) + ;; `file-name-directory' performed by default handler. + ;; `file-name-nondirectory' performed by default handler. + ;; `file-name-sans-versions' performed by default handler. + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) + (file-notify-add-watch . ignore) + (file-notify-rm-watch . ignore) + (file-notify-valid-p . ignore) + (file-ownership-preserved-p . ignore) + (file-readable-p . tramp-archive-handle-file-readable-p) + (file-regular-p . tramp-handle-file-regular-p) + ;; `file-remote-p' performed by default handler. + (file-selinux-context . tramp-handle-file-selinux-context) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-system-info . tramp-archive-handle-file-system-info) + (file-truename . tramp-archive-handle-file-truename) + (file-writable-p . ignore) + (find-backup-file-name . ignore) + ;; `get-file-buffer' performed by default handler. + (insert-directory . tramp-archive-handle-insert-directory) + (insert-file-contents . tramp-archive-handle-insert-file-contents) + (load . tramp-archive-handle-load) + (make-auto-save-file-name . ignore) + (make-directory . tramp-archive-handle-not-implemented) + (make-directory-internal . tramp-archive-handle-not-implemented) + (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-symbolic-link . tramp-archive-handle-not-implemented) + (process-file . ignore) + (rename-file . tramp-archive-handle-not-implemented) + (set-file-acl . ignore) + (set-file-modes . tramp-archive-handle-not-implemented) + (set-file-selinux-context . ignore) + (set-file-times . tramp-archive-handle-not-implemented) + (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) + (shell-command . tramp-archive-handle-not-implemented) + (start-file-process . tramp-archive-handle-not-implemented) + ;; `substitute-in-file-name' performed by default handler. + (temporary-file-directory . tramp-archive-handle-temporary-file-directory) + (unhandled-file-name-directory . ignore) + (vc-registered . ignore) + (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (write-region . tramp-archive-handle-not-implemented)) + "Alist of handler functions for file archive method. +Operations not mentioned here will be handled by the default Emacs primitives.") + +(defsubst tramp-archive-file-name-for-operation (operation &rest args) + "Like `tramp-file-name-for-operation', but for archive file name syntax." + (cl-letf (((symbol-function 'tramp-tramp-file-p) 'tramp-archive-file-name-p)) + (apply 'tramp-file-name-for-operation operation args))) + +(defun tramp-archive-run-real-handler (operation args) + "Invoke normal file name handler for OPERATION. +First arg specifies the OPERATION, second arg is a list of arguments to +pass to the OPERATION." + (let* ((inhibit-file-name-handlers + `(tramp-archive-file-name-handler + . + ,(and (eq inhibit-file-name-operation operation) + inhibit-file-name-handlers))) + (inhibit-file-name-operation operation)) + (apply operation args))) + +;;;###tramp-autoload +(defun tramp-archive-file-name-handler (operation &rest args) + "Invoke the file archive related OPERATION. +First arg specifies the OPERATION, second arg is a list of arguments to +pass to the OPERATION." + (if (not tramp-archive-enabled) + ;; Unregister `tramp-archive-file-name-handler'. + (progn + (tramp-register-file-name-handlers) + (tramp-archive-run-real-handler operation args)) + + (let* ((filename (apply 'tramp-archive-file-name-for-operation + operation args)) + (archive (tramp-archive-file-name-archive filename))) + + ;; The file archive could be a directory, see Bug#30293. + (if (and archive + (tramp-archive-run-real-handler + 'file-directory-p (list archive))) + (tramp-archive-run-real-handler operation args) + ;; Now run the handler. + (let ((tramp-methods (cons `(,tramp-archive-method) tramp-methods)) + (tramp-gvfs-methods tramp-archive-all-gvfs-methods) + ;; Set uid and gid. gvfsd-archive could do it, but it doesn't. + (tramp-unknown-id-integer (user-uid)) + (tramp-unknown-id-string (user-login-name)) + (fn (assoc operation tramp-archive-file-name-handler-alist))) + (when (eq (cdr fn) 'tramp-archive-handle-not-implemented) + (setq args (cons operation args))) + (if fn + (save-match-data (apply (cdr fn) args)) + (tramp-archive-run-real-handler operation args))))))) + +;;;###autoload +(defalias + 'tramp-archive-autoload-file-name-handler 'tramp-autoload-file-name-handler) + +;;;###autoload +(progn (defun tramp-register-archive-file-name-handler () + "Add archive file name handler to `file-name-handler-alist'." + (when tramp-archive-enabled + (add-to-list 'file-name-handler-alist + (cons (tramp-archive-autoload-file-name-regexp) + 'tramp-archive-autoload-file-name-handler)) + (put 'tramp-archive-autoload-file-name-handler 'safe-magic t)))) + +;;;###autoload +(progn + (add-hook 'after-init-hook 'tramp-register-archive-file-name-handler) + (add-hook + 'tramp-archive-unload-hook + (lambda () + (remove-hook + 'after-init-hook 'tramp-register-archive-file-name-handler)))) + +;; In older Emacsen (prior 27.1), the autoload above does not exist. +;; So we call it again; it doesn't hurt. +(tramp-register-archive-file-name-handler) + +;; Mark `operations' the handler is responsible for. +(put 'tramp-archive-file-name-handler 'operations + (mapcar 'car tramp-archive-file-name-handler-alist)) + +;; `tramp-archive-file-name-handler' must be placed before `url-file-handler'. +(when url-handler-mode (tramp-register-file-name-handlers)) + +(eval-after-load 'url-handler + (progn + (add-hook 'url-handler-mode-hook 'tramp-register-file-name-handlers) + (add-hook + 'tramp-archive-unload-hook + (lambda () + (remove-hook + 'url-handler-mode-hook 'tramp-register-file-name-handlers))))) + + +;; File name conversions. + +(defun tramp-archive-file-name-p (name) + "Return t if NAME is a string with archive file name syntax." + (and (stringp name) + ;; We cannot use `string-match-p', the matches are used. + (string-match tramp-archive-file-name-regexp name) + t)) + +(defun tramp-archive-file-name-archive (name) + "Return archive part of NAME." + (and (tramp-archive-file-name-p name) + (match-string 1 name))) + +(defun tramp-archive-file-name-localname (name) + "Return localname part of NAME." + (and (tramp-archive-file-name-p name) + (match-string 2 name))) + +(defvar tramp-archive-hash (make-hash-table :test 'equal) + "Hash table for archive local copies. +The hash key is the archive name. The value is a cons of the +used `tramp-file-name' structure for tramp-gvfs, and the file +name of a local copy, if any.") + +(defsubst tramp-archive-gvfs-host (archive) + "Return host name of ARCHIVE as used in GVFS for mounting" + (url-hexify-string (tramp-gvfs-url-file-name archive))) + +(defun tramp-archive-dissect-file-name (name) + "Return a `tramp-file-name' structure. +The structure consists of the `tramp-archive-method' method, the +hexified archive name as host, and the localname. The archive +name is kept in slot `hop'" + (save-match-data + (unless (tramp-archive-file-name-p name) + (tramp-user-error nil "Not an archive file name: \"%s\"" name)) + (let* ((localname (tramp-archive-file-name-localname name)) + (archive (file-truename (tramp-archive-file-name-archive name))) + (vec (make-tramp-file-name + :method tramp-archive-method :hop archive))) + + (cond + ;; The value is already in the hash table. + ((gethash archive tramp-archive-hash) + (setq vec (car (gethash archive tramp-archive-hash)))) + + ;; File archives inside file archives. + ((tramp-archive-file-name-p archive) + (let ((archive + (tramp-make-tramp-file-name + (tramp-archive-dissect-file-name archive) nil 'noarchive))) + (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive))) + (puthash archive (list vec) tramp-archive-hash)) + + ;; http://... + ((and url-handler-mode + tramp-compat-use-url-tramp-p + (string-match-p url-handler-regexp archive) + (string-match-p + "https?" (url-type (url-generic-parse-url archive)))) + (let* ((url-tramp-protocols + (cons + (url-type (url-generic-parse-url archive)) + url-tramp-protocols)) + (archive (url-tramp-convert-url-to-tramp archive))) + (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive))) + (puthash archive (list vec) tramp-archive-hash)) + + ;; GVFS supported schemes. + ((or (tramp-gvfs-file-name-p archive) + (not (file-remote-p archive))) + (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive)) + (puthash archive (list vec) tramp-archive-hash)) + + ;; Anything else. Here we call `file-local-copy', which we + ;; have avoided so far. + (t (let* ((inhibit-file-name-operation 'file-local-copy) + (inhibit-file-name-handlers + (cons 'jka-compr-handler inhibit-file-name-handlers)) + (copy (file-local-copy archive))) + (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host copy)) + (puthash archive (cons vec copy) tramp-archive-hash)))) + + ;; So far, `vec' handles just the mount point. Add `localname', + ;; which shouldn't be pushed to the hash. + (setf (tramp-file-name-localname vec) localname) + vec))) + +;;;###tramp-autoload +(defun tramp-archive-cleanup-hash () + "Remove local copies of archives, used by GVFS." + (maphash + (lambda (key value) + ;; Unmount local copy. + (ignore-errors + (tramp-message (car value) 3 "Unmounting %s" (or (cdr value) key)) + (tramp-gvfs-unmount (car value))) + ;; Delete local copy. + (ignore-errors (delete-file (cdr value))) + (remhash key tramp-archive-hash)) + tramp-archive-hash) + (clrhash tramp-archive-hash)) + +(add-hook 'kill-emacs-hook 'tramp-archive-cleanup-hash) +(add-hook 'tramp-archive-unload-hook + (lambda () + (remove-hook 'kill-emacs-hook + 'tramp-archive-cleanup-hash))) + +(defsubst tramp-file-name-archive (vec) + "Extract the archive file name from VEC. +VEC is expected to be a `tramp-file-name', with the method being +`tramp-archive-method', and the host being a coded URL. The +archive name is extracted from the hop part of the VEC structure." + (and (tramp-file-name-p vec) + (string-equal (tramp-file-name-method vec) tramp-archive-method) + (tramp-file-name-hop vec))) + +(defmacro with-parsed-tramp-archive-file-name (filename var &rest body) + "Parse an archive filename and make components available in the body. +This works exactly as `with-parsed-tramp-file-name' for the Tramp +file name structure returned by `tramp-archive-dissect-file-name'. +A variable `foo-archive' (or `archive') will be bound to the +archive name part of FILENAME, assuming `foo' (or nil) is the +value of VAR. OTOH, the variable `foo-hop' (or `hop') won't be +offered." + (declare (debug (form symbolp body)) + (indent 2)) + (let ((bindings + (mapcar (lambda (elem) + `(,(if var (intern (format "%s-%s" var elem)) elem) + (,(intern (format "tramp-file-name-%s" elem)) + ,(or var 'v)))) + `,(cons + 'archive + (delete 'hop (tramp-compat-tramp-file-name-slots)))))) + `(let* ((,(or var 'v) (tramp-archive-dissect-file-name ,filename)) + ,@bindings) + ;; We don't know which of those vars will be used, so we bind them all, + ;; and then add here a dummy use of all those variables, so we don't get + ;; flooded by warnings about those vars `body' didn't use. + (ignore ,@(mapcar #'car bindings)) + ,@body))) + +(defun tramp-archive-gvfs-file-name (name) + "Return FILENAME in GVFS syntax." + (tramp-make-tramp-file-name + (tramp-archive-dissect-file-name name) nil 'nohop)) + + +;; File name primitives. + +(defun tramp-archive-handle-copy-file + (filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Like `copy-file' for file archives." + (when (tramp-archive-file-name-p newname) + (tramp-error + (tramp-archive-dissect-file-name newname) 'file-error + "Permission denied: %s" newname)) + (copy-file + (tramp-archive-gvfs-file-name filename) newname ok-if-already-exists + keep-date preserve-uid-gid preserve-extended-attributes)) + +(defun tramp-archive-handle-directory-file-name (directory) + "Like `directory-file-name' for file archives." + (with-parsed-tramp-archive-file-name directory nil + (if (and (not (zerop (length localname))) + (eq (aref localname (1- (length localname))) ?/) + (not (string= localname "/"))) + (substring directory 0 -1) + ;; We do not want to leave the file archive. This would require + ;; unnecessary download of http-based file archives, for + ;; example. So we return `directory'. + directory))) + +(defun tramp-archive-handle-dired-uncache (dir) + "Like `dired-uncache' for file archives." + (dired-uncache (tramp-archive-gvfs-file-name dir))) + +(defun tramp-archive-handle-file-attributes (filename &optional id-format) + "Like `file-attributes' for file archives." + (file-attributes (tramp-archive-gvfs-file-name filename) id-format)) + +(defun tramp-archive-handle-file-executable-p (filename) + "Like `file-executable-p' for file archives." + (file-executable-p (tramp-archive-gvfs-file-name filename))) + +(defun tramp-archive-handle-file-local-copy (filename) + "Like `file-local-copy' for file archives." + (file-local-copy (tramp-archive-gvfs-file-name filename))) + +(defun tramp-archive-handle-file-name-all-completions (filename directory) + "Like `file-name-all-completions' for file archives." + (file-name-all-completions filename (tramp-archive-gvfs-file-name directory))) + +(defun tramp-archive-handle-file-readable-p (filename) + "Like `file-readable-p' for file archives." + (with-parsed-tramp-file-name + (tramp-archive-gvfs-file-name filename) nil + (tramp-check-cached-permissions v ?r))) + +(defun tramp-archive-handle-file-system-info (filename) + "Like `file-system-info' for file archives." + (with-parsed-tramp-archive-file-name filename nil + (list (tramp-compat-file-attribute-size (file-attributes archive)) 0 0))) + +(defun tramp-archive-handle-file-truename (filename) + "Like `file-truename' for file archives." + (with-parsed-tramp-archive-file-name filename nil + (let ((local (or (file-symlink-p filename) localname))) + (unless (file-name-absolute-p local) + (setq local (expand-file-name local (file-name-directory localname)))) + (concat (file-truename archive) local)))) + +(defun tramp-archive-handle-insert-directory + (filename switches &optional wildcard full-directory-p) + "Like `insert-directory' for file archives." + (insert-directory + (tramp-archive-gvfs-file-name filename) switches wildcard full-directory-p) + (goto-char (point-min)) + (while (search-forward (tramp-archive-gvfs-file-name filename) nil 'noerror) + (replace-match filename))) + +(defun tramp-archive-handle-insert-file-contents + (filename &optional visit beg end replace) + "Like `insert-file-contents' for file archives." + (let ((result + (insert-file-contents + (tramp-archive-gvfs-file-name filename) visit beg end replace))) + (prog1 + (list (expand-file-name filename) + (cadr result)) + (when visit (setq buffer-file-name filename))))) + +(defun tramp-archive-handle-load + (file &optional noerror nomessage nosuffix must-suffix) + "Like `load' for file archives." + (load + (tramp-archive-gvfs-file-name file) noerror nomessage nosuffix must-suffix)) + +(defun tramp-archive-handle-temporary-file-directory () + "Like `temporary-file-directory' for file archives." + ;; If the default directory, the file archive, is located on a + ;; mounted directory, it is returned as it. Not what we want. + (with-parsed-tramp-archive-file-name default-directory nil + (let ((default-directory (file-name-directory archive))) + (tramp-compat-temporary-file-directory)))) + +(defun tramp-archive-handle-not-implemented (operation &rest args) + "Generic handler for operations not implemented for file archives." + (let ((v (ignore-errors + (tramp-archive-dissect-file-name + (apply 'tramp-archive-file-name-for-operation operation args))))) + (tramp-message v 10 "%s" (cons operation args)) + (tramp-error + v 'file-error + "Operation `%s' not implemented for file archives" operation))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-archive 'force))) + +(provide 'tramp-archive) + +;;; TODO: + +;; * Check, whether we could retrieve better file attributes like uid, +;; gid, permissions. See gvfsbackendarchive.c +;; (archive_file_set_info_from_entry), where it is commented out. +;; +;; * Implement write access, when possible. +;; https://bugzilla.gnome.org/show_bug.cgi?id=589617 + +;;; tramp-archive.el ends here diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 1db93eadf6b..0a799d721d6 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -28,7 +28,7 @@ ;; An implementation of information caching for remote files. ;; Each connection, identified by a `tramp-file-name' structure or by -;; a process, has a unique cache. We distinguish 3 kind of caches, +;; a process, has a unique cache. We distinguish 4 kind of caches, ;; depending on the key: ;; ;; - localname is NIL. This are reusable properties. Examples: @@ -49,6 +49,16 @@ ;; an open connection. Examples: "scripts" keeps shell script ;; definitions already sent to the remote shell, "last-cmd-time" is ;; the time stamp a command has been sent to the remote process. +;; +;; - The key is `nil'. This are temporary properties related to the +;; local machine. Examples: "parse-passwd" and "parse-group" keep +;; the results of parsing "/etc/passwd" and "/etc/group", "locale" +;; is the used shell locale. + +;; Some properties are handled special: +;; +;; - "process-name", "process-buffer" and "first-password-request" are +;; not saved in the file `tramp-persistency-file-name'. ;;; Code: @@ -94,12 +104,9 @@ matching entries of `tramp-connection-properties'." (puthash key (make-hash-table :test 'equal) tramp-cache-data))) (when (tramp-file-name-p key) (dolist (elt tramp-connection-properties) - (when (string-match + (when (string-match-p (or (nth 0 elt) "") - (tramp-make-tramp-file-name - (tramp-file-name-method key) (tramp-file-name-user key) - (tramp-file-name-domain key) (tramp-file-name-host key) - (tramp-file-name-port key) nil)) + (tramp-make-tramp-file-name key 'noloc 'nohop)) (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) hash))) @@ -115,16 +122,14 @@ Returns DEFAULT if not set." (tramp-file-name-hop key) nil) (let* ((hash (tramp-get-hash-table key)) (value (when (hash-table-p hash) (gethash property hash)))) - (if - ;; We take the value only if there is any, and + (if ;; We take the value only if there is any, and ;; `remote-file-name-inhibit-cache' indicates that it is still ;; valid. Otherwise, DEFAULT is set. (and (consp value) (or (null remote-file-name-inhibit-cache) (and (integerp remote-file-name-inhibit-cache) - (<= - (tramp-time-diff (current-time) (car value)) - remote-file-name-inhibit-cache)) + (<= (tramp-time-diff (current-time) (car value)) + remote-file-name-inhibit-cache)) (and (consp remote-file-name-inhibit-cache) (time-less-p remote-file-name-inhibit-cache (car value))))) @@ -167,7 +172,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))) @@ -182,10 +202,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)) @@ -197,14 +217,14 @@ Remove also properties of all files in subdirectories." (lambda (key _value) (when (and (tramp-file-name-p key) (stringp (tramp-file-name-localname key)) - (string-match (regexp-quote directory) - (tramp-file-name-localname key))) + (string-match-p (regexp-quote directory) + (tramp-file-name-localname key))) (remhash key tramp-cache-data))) tramp-cache-data) ;; Remove file properties of symlinks. (when (and (stringp truename) (not (string-equal directory (directory-file-name truename)))) - (tramp-flush-directory-property key truename)))) + (tramp-flush-directory-properties key truename)))) ;; Reverting or killing a buffer should also flush file properties. ;; They could have been changed outside Tramp. In eshell, "ls" would @@ -216,14 +236,14 @@ Remove also properties of all files in subdirectories." This is suppressed for temporary buffers." (save-match-data (unless (or (null (buffer-name)) - (string-match "^\\( \\|\\*\\)" (buffer-name))) + (string-match-p "^\\( \\|\\*\\)" (buffer-name))) (let ((bfn (if (stringp (buffer-file-name)) (buffer-file-name) default-directory)) (tramp-verbose 0)) (when (tramp-tramp-file-p bfn) (with-parsed-tramp-file-name bfn nil - (tramp-flush-file-property v localname))))))) + (tramp-flush-file-properties v localname))))))) (add-hook 'before-revert-hook 'tramp-flush-file-function) (add-hook 'eshell-pre-command-hook 'tramp-flush-file-function) @@ -292,7 +312,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 @@ -385,6 +422,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 7adac135ae7..b886223c95c 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -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,23 @@ This includes password cache, file cache, connection cache, buffers." ;; Flush file and connection cache. (clrhash tramp-cache-data) + ;; Cleanup local copies of archives. + (when (bound-and-true-p tramp-archive-enabled) + (tramp-archive-cleanup-hash)) + + ;; Remove ad-hoc proxies. + (let ((proxies tramp-default-proxies-alist)) + (while proxies + (if (ignore-errors + (get-text-property 0 'tramp-ad-hoc (nth 2 (car proxies)))) + (setq tramp-default-proxies-alist + (delete (car proxies) tramp-default-proxies-alist) + proxies tramp-default-proxies-alist) + (setq proxies (cdr proxies))))) + (when (and tramp-default-proxies-alist tramp-save-ad-hoc-proxies) + (customize-save-variable + 'tramp-default-proxies-alist tramp-default-proxies-alist)) + ;; Remove buffers. (dolist (name (tramp-list-tramp-buffers)) (when (bufferp (get-buffer name)) (kill-buffer name)))) @@ -186,10 +194,13 @@ This includes password cache, file cache, connection cache, buffers." "Submit a bug report to the Tramp developers." (interactive) (catch 'dont-send - (let ((reporter-prompt-for-summary-p t)) + (let ((reporter-prompt-for-summary-p t) + ;; In rare cases, it could contain the password. So we make it nil. + tramp-password-save-function) (reporter-submit-bug-report - tramp-bug-report-address ; to-address - (format "tramp (%s)" tramp-version) ; package name and version + tramp-bug-report-address ; to-address + (format "tramp (%s %s/%s)" ; package name and version + tramp-version tramp-repository-branch tramp-repository-version) (sort (delq nil (mapcar (lambda (x) @@ -250,7 +261,7 @@ buffer in your bug report. (set varsym (read (format "(%s)" (tramp-cache-print val)))) ;; There are non-7bit characters to be masked. (when (and (stringp val) - (string-match + (string-match-p (concat "[^" (bound-and-true-p mm-7bit-chars) "]") val)) (with-current-buffer reporter-eval-buffer (set @@ -266,10 +277,11 @@ buffer in your bug report. ;; Remove string quotation. (forward-line -1) (when (looking-at - (concat "\\(^.*\\)" "\"" ;; \1 " - "\\((base64-decode-string \\)" "\\\\" ;; \2 \ - "\\(\".*\\)" "\\\\" ;; \3 \ - "\\(\")\\)" "\"$")) ;; \4 " + (eval-when-compile + (concat "\\(^.*\\)" "\"" ;; \1 " + "\\((base64-decode-string \\)" "\\\\" ;; \2 \ + "\\(\".*\\)" "\\\\" ;; \3 \ + "\\(\")\\)" "\"$"))) ;; \4 " (replace-match "\\1\\2\\3\\4") (beginning-of-line) (insert " ;; Variable encoded due to non-printable characters.\n")) @@ -294,7 +306,7 @@ buffer in your bug report. (delq nil (mapcar (lambda (b) - (when (string-match "\\*tramp/" (buffer-name b)) b)) + (when (string-match-p "\\*tramp/" (buffer-name b)) b)) (buffer-list)))) (let ((reporter-eval-buffer buffer) (elbuf (get-buffer-create " *tmp-reporter-buffer*"))) @@ -322,7 +334,7 @@ buffer in your bug report. (insert "\nload-path shadows:\n==================\n") (ignore-errors (mapc - (lambda (x) (when (string-match "tramp" x) (insert x "\n"))) + (lambda (x) (when (string-match-p "tramp" x) (insert x "\n"))) (split-string (list-load-path-shadows t) "\n"))) ;; Append buffers only when we are in message mode. diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 5bf57638ff8..046966e0190 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -29,6 +29,11 @@ ;;; Code: +;; In Emacs 24 and 25, `tramp-unload-file-name-handlers' is not +;; autoloaded. So we declare it here in order to avoid recursive +;; load. This will be overwritten in tramp.el. +(defun tramp-unload-file-name-handlers ()) + (require 'auth-source) (require 'advice) (require 'cl-lib) @@ -40,7 +45,6 @@ (require 'timer) (require 'ucs-normalize) -(require 'trampver) (require 'tramp-loaddefs) ;; For not existing functions, obsolete functions, or functions with a @@ -93,18 +97,11 @@ Add the extension of F, if existing." ;; The returned command name could be truncated ;; to 15 characters. Therefore, we cannot check ;; for `string-equal'. - (and comm (string-match + (and comm (string-match-p (concat "^" (regexp-quote comm)) process-name)))) (setq result t))))))))) -;; `user-error' has appeared in Emacs 24.3. -(defsubst tramp-compat-user-error (vec-or-proc format &rest args) - "Signal a pilot error." - (apply - 'tramp-error vec-or-proc - (if (fboundp 'user-error) 'user-error 'error) format args)) - ;; `default-toplevel-value' has been declared in Emacs 24.4. (unless (fboundp 'default-toplevel-value) (defalias 'default-toplevel-value 'symbol-value)) @@ -150,15 +147,15 @@ returned." (defsubst tramp-compat-file-attribute-modification-time (attributes) "The modification time in ATTRIBUTES returned by `file-attributes'. This is the time of the last change to the file's contents, and -is a list of integers (HIGH LOW USEC PSEC) in the same style -as (current-time)." +is a Lisp timestamp in the style of `current-time'." (nth 5 attributes))) (if (fboundp 'file-attribute-size) (defalias 'tramp-compat-file-attribute-size 'file-attribute-size) (defsubst tramp-compat-file-attribute-size (attributes) "The size (in bytes) in ATTRIBUTES returned by `file-attributes'. -This is a floating point number if the size is too large for an integer." +If the size is too large for a fixnum, this is a bignum in Emacs 27 +and later, and is a float in Emacs 26 and earlier." (nth 7 attributes))) (if (fboundp 'file-attribute-modes) @@ -190,20 +187,23 @@ 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. +;; `file-local-name', `file-name-quoted-p', `file-name-quote' and +;; `file-name-unquote' are introduced in Emacs 26. (eval-and-compile + (if (fboundp 'file-local-name) + (defalias 'tramp-compat-file-local-name 'file-local-name) + (defsubst tramp-compat-file-local-name (name) + "Return the local name component of NAME. +It returns a file name which can be used directly as argument of +`process-file', `start-file-process', or `shell-command'." + (or (file-remote-p name 'localname) name))) + (if (fboundp 'file-name-quoted-p) (defalias 'tramp-compat-file-name-quoted-p 'file-name-quoted-p) (defsubst tramp-compat-file-name-quoted-p (name) "Whether NAME is quoted with prefix \"/:\". If NAME is a remote file name, check the local part of NAME." - (string-match "^/:" (or (file-remote-p name 'localname) name)))) + (string-prefix-p "/:" (tramp-compat-file-local-name name)))) (if (fboundp 'file-name-quote) (defalias 'tramp-compat-file-name-quote 'file-name-quote) @@ -213,21 +213,18 @@ If NAME is a remote file name, the local part of NAME is quoted." (if (tramp-compat-file-name-quoted-p name) name (concat - (file-remote-p name) "/:" (or (file-remote-p name 'localname) name))))) + (file-remote-p name) "/:" (tramp-compat-file-local-name name))))) (if (fboundp 'file-name-unquote) (defalias 'tramp-compat-file-name-unquote 'file-name-unquote) (defsubst tramp-compat-file-name-unquote (name) "Remove quotation prefix \"/:\" from file NAME. If NAME is a remote file name, the local part of NAME is unquoted." - (save-match-data - (let ((localname (or (file-remote-p name 'localname) name))) - (when (tramp-compat-file-name-quoted-p localname) - (setq - localname - (replace-match - (if (= (length localname) 2) "/" "") nil t localname))) - (concat (file-remote-p name) localname)))))) + (let ((localname (tramp-compat-file-local-name name))) + (when (tramp-compat-file-name-quoted-p localname) + (setq + localname (if (= (length localname) 2) "/" (substring localname 2)))) + (concat (file-remote-p name) localname))))) ;; `tramp-syntax' has changed its meaning in Emacs 26. We still ;; support old settings. @@ -240,11 +237,57 @@ If NAME is a remote file name, the local part of NAME is unquoted." ;; `cl-struct-slot-info' has been introduced with Emacs 25. (defmacro tramp-compat-tramp-file-name-slots () (if (fboundp 'cl-struct-slot-info) - `(cdr (mapcar 'car (cl-struct-slot-info 'tramp-file-name))) - `(cdr (mapcar 'car (get 'tramp-file-name 'cl-struct-slots))))) + '(cdr (mapcar 'car (cl-struct-slot-info 'tramp-file-name))) + '(cdr (mapcar 'car (get 'tramp-file-name 'cl-struct-slots))))) + +;; The signature of `tramp-make-tramp-file-name' has been changed. +;; Therefore, we cannot 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.") + +;; `exec-path' is new in Emacs 27.1. +(eval-and-compile + (if (fboundp 'exec-path) + (defalias 'tramp-compat-exec-path 'exec-path) + (defun tramp-compat-exec-path () + "List of directories to search programs to run in remote subprocesses." + (let ((handler (find-file-name-handler default-directory 'exec-path))) + (if handler + (funcall handler 'exec-path) + exec-path))))) + +;; `time-equal-p' has appeared in Emacs 27.1. +(if (fboundp 'time-equal-p) + (defalias 'tramp-compat-time-equal-p 'time-equal-p) + (defsubst tramp-compat-time-equal-p (t1 t2) + "Return non-nil if time value T1 is equal to time value T2. +A nil value for either argument stands for the current time." + (equal (or t1 (current-time)) (or t2 (current-time))))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-loaddefs 'force) + (unload-feature 'tramp-compat 'force))) + +;; There does not exist a common `flatten-list' yet, this is discussed +;; in Bug#33309. For the time being we implement our own version, +;; derived from `eshell-flatten-list'. +(defun tramp-compat-flatten-list (args) + "Flatten any lists within ARGS, so that there are no sublists." + (let ((new-list (list t))) + (dolist (a args) + (if (and (listp a) + (listp (cdr a))) + (nconc new-list (tramp-compat-flatten-list a)) + (nconc new-list (list a)))) + (cdr new-list))) (provide 'tramp-compat) ;;; TODO: +;; * When we get rid of Emacs 24, replace "(mapconcat 'identity" by +;; "(string-join". + ;;; tramp-compat.el ends here diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index 983f168ddb4..5d8b56e218f 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -183,8 +183,9 @@ pass to the OPERATION." ;;;###tramp-autoload (defsubst tramp-ftp-file-name-p (filename) "Check if it's a filename that should be forwarded to Ange-FTP." - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-ftp-method)) + (and (tramp-tramp-file-p filename) + (string= (tramp-file-name-method (tramp-dissect-file-name filename)) + tramp-ftp-method))) ;;;###tramp-autoload (add-to-list 'tramp-foreign-file-name-handler-alist diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 39962de8342..e034f7bba56 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -47,17 +47,19 @@ ;; discovered during development time, is given in respective ;; comments. -;; The custom option `tramp-gvfs-methods' contains the list of -;; supported connection methods. Per default, these are "afp", "dav", -;; "davs", "gdrive", "obex", "sftp" and "synce". Note that with -;; "obex" it might be necessary to pair with the other bluetooth -;; device, if it hasn't been done already. There might be also some -;; few seconds delay in discovering available bluetooth devices. - -;; Other possible connection methods are "ftp" and "smb". When one of -;; these methods is added to the list, the remote access for that -;; method is performed via GVFS instead of the native Tramp -;; implementation. +;; The user option `tramp-gvfs-methods' contains the list of supported +;; connection methods. Per default, these are "afp", "dav", "davs", +;; "gdrive", "nextcloud" and "sftp". + +;; "gdrive" and "nextcloud" connection methods require a respective +;; account in GNOME Online Accounts, with enabled "Files" service. + +;; Other possible connection methods are "ftp", "http", "https" and +;; "smb". When one of these methods is added to the list, the remote +;; access for that method is performed via GVFS instead of the native +;; Tramp implementation. However, this is not recommended. These +;; methods are listed here for the benefit of file archives, see +;; tramp-archive.el. ;; GVFS offers even more connection methods. The complete list of ;; connection methods of the actual GVFS implementation can be @@ -71,23 +73,21 @@ ;; :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker ;; tramp-gvfs-interface-mounttracker "ListMountableInfo"))) +;; See also /usr/share/gvfs/mounts + ;; Note that all other connection methods are not tested, beside the ;; ones offered for customization in `tramp-gvfs-methods'. If you ;; request an additional connection method to be supported, please ;; drop me a note. -;; For hostname completion, information is retrieved either from the -;; bluez daemon (for the "obex" method), the hal daemon (for the -;; "synce" method), or from the zeroconf daemon (for the "afp", "dav", -;; "davs", and "sftp" methods). The zeroconf daemon is pre-configured -;; to discover services in the "local" domain. If another domain -;; shall be used for discovering services, the custom option -;; `tramp-gvfs-zeroconf-domain' can be set accordingly. +;; For hostname completion, information is retrieved from the zeroconf +;; daemon (for the "afp", "dav", "davs", and "sftp" methods). The +;; zeroconf daemon is pre-configured to discover services in the +;; "local" domain. If another domain shall be used for discovering +;; services, the user option `tramp-gvfs-zeroconf-domain' can be set +;; accordingly. ;; Restrictions: - -;; * The current GVFS implementation does not allow writing on the -;; remote bluetooth device via OBEX. ;; ;; * Two shares of the same SMB server cannot be mounted in parallel. @@ -97,6 +97,7 @@ ;; option "--without-dbus". Declare used subroutines and variables. (declare-function dbus-get-unique-name "dbusbind.c") +(eval-when-compile (require 'cl-lib)) (require 'tramp) (require 'dbus) @@ -108,21 +109,41 @@ (eval-when-compile (require 'custom)) +;; We don't call `dbus-ping', because this would load dbus.el. +(defconst tramp-gvfs-enabled + (ignore-errors + (and (featurep 'dbusbind) + (tramp-compat-funcall 'dbus-get-unique-name :system) + (tramp-compat-funcall 'dbus-get-unique-name :session) + (or (tramp-compat-process-running-p "gvfs-fuse-daemon") + (tramp-compat-process-running-p "gvfsd-fuse")))) + "Non-nil when GVFS is available.") + ;;;###tramp-autoload (defcustom tramp-gvfs-methods - '("afp" "dav" "davs" "gdrive" "obex" "sftp" "synce") + '("afp" "dav" "davs" "gdrive" "nextcloud" "sftp") "List of methods for remote files, accessed with GVFS." :group 'tramp - :version "26.1" + :version "27.1" :type '(repeat (choice (const "afp") (const "dav") (const "davs") (const "ftp") (const "gdrive") - (const "obex") + (const "http") + (const "https") + (const "nextcloud") (const "sftp") - (const "smb") - (const "synce")))) + (const "smb")))) + +(defconst tramp-goa-methods '("gdrive" "nextcloud") + "List of methods which require registration at GNOME Online Accounts.") + +;; Remove GNOME Online Accounts methods if not supported. +(unless (and tramp-gvfs-enabled + (member tramp-goa-service (dbus-list-known-names :session))) + (dolist (method tramp-goa-methods) + (setq tramp-gvfs-methods (delete method tramp-gvfs-methods)))) ;; Add defaults for `tramp-default-user-alist' and `tramp-default-host-alist'. ;;;###tramp-autoload @@ -132,8 +153,6 @@ `("\\`gdrive\\'" nil ,(match-string 1 user-mail-address))) (add-to-list 'tramp-default-host-alist '("\\`gdrive\\'" nil ,(match-string 2 user-mail-address)))) -;;;###tramp-autoload -(add-to-list 'tramp-default-user-alist '("\\`synce\\'" nil nil)) ;;;###tramp-autoload (defcustom tramp-gvfs-zeroconf-domain "local" @@ -156,16 +175,6 @@ (defconst tramp-gvfs-service-daemon "org.gtk.vfs.Daemon" "The well known name of the GVFS daemon.") -;; We don't call `dbus-ping', because this would load dbus.el. -(defconst tramp-gvfs-enabled - (ignore-errors - (and (featurep 'dbusbind) - (tramp-compat-funcall 'dbus-get-unique-name :system) - (tramp-compat-funcall 'dbus-get-unique-name :session) - (or (tramp-compat-process-running-p "gvfs-fuse-daemon") - (tramp-compat-process-running-p "gvfsd-fuse")))) - "Non-nil when GVFS is available.") - (defconst tramp-gvfs-path-mounttracker "/org/gtk/vfs/mounttracker" "The object path of the GVFS daemon.") @@ -287,131 +296,161 @@ It has been changed in GVFS 1.14.") (defconst tramp-gvfs-password-anonymous-supported 16 "Operation supports anonymous users.") -(defconst tramp-bluez-service "org.bluez" - "The well known name of the BLUEZ service.") +;; For the time being, we just need org.goa.Account and org.goa.Files +;; interfaces. We document the other ones, just in case. -(defconst tramp-bluez-interface-manager "org.bluez.Manager" - "The manager interface of the BLUEZ daemon.") +;;;###tramp-autoload +(defconst tramp-goa-service "org.gnome.OnlineAccounts" + "The well known name of the GNOME Online Accounts service.") -;; <interface name='org.bluez.Manager'> -;; <method name='DefaultAdapter'> -;; <arg type='o' direction='out'/> -;; </method> -;; <method name='FindAdapter'> -;; <arg type='s' direction='in'/> -;; <arg type='o' direction='out'/> -;; </method> -;; <method name='ListAdapters'> -;; <arg type='ao' direction='out'/> -;; </method> -;; <signal name='AdapterAdded'> -;; <arg type='o'/> -;; </signal> -;; <signal name='AdapterRemoved'> -;; <arg type='o'/> -;; </signal> -;; <signal name='DefaultAdapterChanged'> -;; <arg type='o'/> -;; </signal> +(defconst tramp-goa-path "/org/gnome/OnlineAccounts" + "The object path of the GNOME Online Accounts.") + +(defconst tramp-goa-path-accounts (concat tramp-goa-path "/Accounts") + "The object path of the GNOME Online Accounts accounts.") + +(defconst tramp-goa-interface-documents "org.gnome.OnlineAccounts.Documents" + "The documents interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Documents'> ;; </interface> -(defconst tramp-bluez-interface-adapter "org.bluez.Adapter" - "The adapter interface of the BLUEZ daemon.") +(defconst tramp-goa-interface-printers "org.gnome.OnlineAccounts.Printers" + "The printers interface of the GNOME Online Accounts.") -;; <interface name='org.bluez.Adapter'> -;; <method name='GetProperties'> -;; <arg type='a{sv}' direction='out'/> -;; </method> -;; <method name='SetProperty'> -;; <arg type='s' direction='in'/> -;; <arg type='v' direction='in'/> -;; </method> -;; <method name='RequestMode'> -;; <arg type='s' direction='in'/> -;; </method> -;; <method name='ReleaseMode'/> -;; <method name='RequestSession'/> -;; <method name='ReleaseSession'/> -;; <method name='StartDiscovery'/> -;; <method name='StopDiscovery'/> -;; <method name='ListDevices'> -;; <arg type='ao' direction='out'/> -;; </method> -;; <method name='CreateDevice'> -;; <arg type='s' direction='in'/> -;; <arg type='o' direction='out'/> -;; </method> -;; <method name='CreatePairedDevice'> -;; <arg type='s' direction='in'/> -;; <arg type='o' direction='in'/> -;; <arg type='s' direction='in'/> -;; <arg type='o' direction='out'/> -;; </method> -;; <method name='CancelDeviceCreation'> -;; <arg type='s' direction='in'/> -;; </method> -;; <method name='RemoveDevice'> -;; <arg type='o' direction='in'/> -;; </method> -;; <method name='FindDevice'> -;; <arg type='s' direction='in'/> -;; <arg type='o' direction='out'/> -;; </method> -;; <method name='RegisterAgent'> -;; <arg type='o' direction='in'/> -;; <arg type='s' direction='in'/> +;; <interface name='org.gnome.OnlineAccounts.Printers'> +;; </interface> + +(defconst tramp-goa-interface-files "org.gnome.OnlineAccounts.Files" + "The files interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Files'> +;; <property type='b' name='AcceptSslErrors' access='read'/> +;; <property type='s' name='Uri' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-contacts "org.gnome.OnlineAccounts.Contacts" + "The contacts interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Contacts'> +;; <property type='b' name='AcceptSslErrors' access='read'/> +;; <property type='s' name='Uri' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-calendar "org.gnome.OnlineAccounts.Calendar" + "The calendar interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Calendar'> +;; <property type='b' name='AcceptSslErrors' access='read'/> +;; <property type='s' name='Uri' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-oauth2based "org.gnome.OnlineAccounts.OAuth2Based" + "The oauth2based interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.OAuth2Based'> +;; <method name='GetAccessToken'> +;; <arg type='s' name='access_token' direction='out'/> +;; <arg type='i' name='expires_in' direction='out'/> ;; </method> -;; <method name='UnregisterAgent'> -;; <arg type='o' direction='in'/> +;; <property type='s' name='ClientId' access='read'/> +;; <property type='s' name='ClientSecret' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-account "org.gnome.OnlineAccounts.Account" + "The account interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Account'> +;; <method name='Remove'/> +;; <method name='EnsureCredentials'> +;; <arg type='i' name='expires_in' direction='out'/> ;; </method> -;; <signal name='DeviceCreated'> -;; <arg type='o'/> -;; </signal> -;; <signal name='DeviceRemoved'> -;; <arg type='o'/> -;; </signal> -;; <signal name='DeviceFound'> -;; <arg type='s'/> -;; <arg type='a{sv}'/> -;; </signal> -;; <signal name='PropertyChanged'> -;; <arg type='s'/> -;; <arg type='v'/> -;; </signal> -;; <signal name='DeviceDisappeared'> -;; <arg type='s'/> -;; </signal> +;; <property type='s' name='ProviderType' access='read'/> +;; <property type='s' name='ProviderName' access='read'/> +;; <property type='s' name='ProviderIcon' access='read'/> +;; <property type='s' name='Id' access='read'/> +;; <property type='b' name='IsLocked' access='read'/> +;; <property type='b' name='IsTemporary' access='readwrite'/> +;; <property type='b' name='AttentionNeeded' access='read'/> +;; <property type='s' name='Identity' access='read'/> +;; <property type='s' name='PresentationIdentity' access='read'/> +;; <property type='b' name='MailDisabled' access='readwrite'/> +;; <property type='b' name='CalendarDisabled' access='readwrite'/> +;; <property type='b' name='ContactsDisabled' access='readwrite'/> +;; <property type='b' name='ChatDisabled' access='readwrite'/> +;; <property type='b' name='DocumentsDisabled' access='readwrite'/> +;; <property type='b' name='MapsDisabled' access='readwrite'/> +;; <property type='b' name='MusicDisabled' access='readwrite'/> +;; <property type='b' name='PrintersDisabled' access='readwrite'/> +;; <property type='b' name='PhotosDisabled' access='readwrite'/> +;; <property type='b' name='FilesDisabled' access='readwrite'/> +;; <property type='b' name='TicketingDisabled' access='readwrite'/> +;; <property type='b' name='TodoDisabled' access='readwrite'/> +;; <property type='b' name='ReadLaterDisabled' access='readwrite'/> ;; </interface> -;;;###tramp-autoload -(defcustom tramp-bluez-discover-devices-timeout 60 - "Defines seconds since last bluetooth device discovery before rescanning. -A value of 0 would require an immediate discovery during hostname -completion, nil means to use always cached values for discovered -devices." - :group 'tramp - :version "23.2" - :type '(choice (const nil) integer)) +(defconst tramp-goa-identity-regexp + (concat "^" "\\(" tramp-user-regexp "\\)?" + "@" "\\(" tramp-host-regexp "\\)?" + "\\(?:" ":""\\(" tramp-port-regexp "\\)" "\\)?") + "Regexp matching GNOME Online Accounts \"PresentationIdentity\" property.") + +(defconst tramp-goa-interface-mail "org.gnome.OnlineAccounts.Mail" + "The mail interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Mail'> +;; <property type='s' name='EmailAddress' access='read'/> +;; <property type='s' name='Name' access='read'/> +;; <property type='b' name='ImapSupported' access='read'/> +;; <property type='b' name='ImapAcceptSslErrors' access='read'/> +;; <property type='s' name='ImapHost' access='read'/> +;; <property type='b' name='ImapUseSsl' access='read'/> +;; <property type='b' name='ImapUseTls' access='read'/> +;; <property type='s' name='ImapUserName' access='read'/> +;; <property type='b' name='SmtpSupported' access='read'/> +;; <property type='b' name='SmtpAcceptSslErrors' access='read'/> +;; <property type='s' name='SmtpHost' access='read'/> +;; <property type='b' name='SmtpUseAuth' access='read'/> +;; <property type='b' name='SmtpAuthLogin' access='read'/> +;; <property type='b' name='SmtpAuthPlain' access='read'/> +;; <property type='b' name='SmtpAuthXoauth2' access='read'/> +;; <property type='b' name='SmtpUseSsl' access='read'/> +;; <property type='b' name='SmtpUseTls' access='read'/> +;; <property type='s' name='SmtpUserName' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-chat "org.gnome.OnlineAccounts.Chat" + "The chat interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Chat'> +;; </interface> -(defvar tramp-bluez-discovery nil - "Indicator for a running bluetooth device discovery. -It keeps the timestamp of last discovery.") +(defconst tramp-goa-interface-photos "org.gnome.OnlineAccounts.Photos" + "The photos interface of the GNOME Online Accounts.") -(defvar tramp-bluez-devices nil - "Alist of detected bluetooth devices. -Every entry is a list (NAME ADDRESS).") +;; <interface name='org.gnome.OnlineAccounts.Photos'> +;; </interface> -(defconst tramp-hal-service "org.freedesktop.Hal" - "The well known name of the HAL service.") +(defconst tramp-goa-path-manager (concat tramp-goa-path "/Manager") + "The object path of the GNOME Online Accounts manager.") -(defconst tramp-hal-path-manager "/org/freedesktop/Hal/Manager" - "The object path of the HAL daemon manager.") +(defconst tramp-goa-interface-documents "org.gnome.OnlineAccounts.Manager" + "The manager interface of the GNOME Online Accounts.") -(defconst tramp-hal-interface-manager "org.freedesktop.Hal.Manager" - "The manager interface of the HAL daemon.") +;; <interface name='org.gnome.OnlineAccounts.Manager'> +;; <method name='AddAccount'> +;; <arg type='s' name='provider' direction='in'/> +;; <arg type='s' name='identity' direction='in'/> +;; <arg type='s' name='presentation_identity' direction='in'/> +;; <arg type='a{sv}' name='credentials' direction='in'/> +;; <arg type='a{ss}' name='details' direction='in'/> +;; <arg type='o' name='account_object_path' direction='out'/> +;; </method> +;; </interface> -(defconst tramp-hal-interface-device "org.freedesktop.Hal.Device" - "The device interface of the HAL daemon.") +;; The basic structure for GNOME Online Accounts. We use a list :type, +;; in order to be compatible with Emacs 24 and 25. +(cl-defstruct (tramp-goa-name (:type list) :named) method user host port) ;; "gvfs-<command>" utilities have been deprecated in GVFS 1.31.1. We ;; must use "gio <command>" tool instead. @@ -421,11 +460,13 @@ Every entry is a list (NAME ADDRESS).") ("gvfs-ls" . "list") ("gvfs-mkdir" . "mkdir") ("gvfs-monitor-file" . "monitor") + ("gvfs-mount" . "mount") ("gvfs-move" . "move") ("gvfs-rm" . "remove") ("gvfs-trash" . "trash")) "List of cons cells, mapping \"gvfs-<command>\" to \"gio <command>\".") +;; <http://www.pygtk.org/docs/pygobject/gio-constants.html> (defconst tramp-gvfs-file-attributes '("name" "type" @@ -470,6 +511,13 @@ Every entry is a list (NAME ADDRESS).") ":[[:blank:]]+\\(.*\\)$") "Regexp to parse GVFS file system attributes with `gvfs-info'.") +(defconst tramp-gvfs-nextcloud-default-prefix "/remote.php/webdav" + "Default prefix for owncloud / nextcloud methods.") + +(defconst tramp-gvfs-nextcloud-default-prefix-regexp + (concat (regexp-quote tramp-gvfs-nextcloud-default-prefix) "$") + "Regexp of default prefix for owncloud / nextcloud methods.") + ;; New handlers should be added here. ;;;###tramp-autoload @@ -488,16 +536,17 @@ Every entry is a list (NAME ADDRESS).") . tramp-handle-directory-files-and-attributes) (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) + (exec-path . ignore) (expand-file-name . tramp-gvfs-handle-expand-file-name) (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . ignore) (file-attributes . tramp-gvfs-handle-file-attributes) - (file-directory-p . tramp-gvfs-handle-file-directory-p) + (file-directory-p . tramp-handle-file-directory-p) (file-equal-p . tramp-handle-file-equal-p) (file-executable-p . tramp-gvfs-handle-file-executable-p) (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) - (file-local-copy . tramp-gvfs-handle-file-local-copy) + (file-local-copy . tramp-handle-file-local-copy) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-gvfs-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) @@ -518,9 +567,8 @@ Every entry is a list (NAME ADDRESS).") (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-gvfs-handle-file-system-info) (file-truename . tramp-handle-file-truename) - (file-writable-p . tramp-gvfs-handle-file-writable-p) + (file-writable-p . tramp-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) - ;; `find-file-noselect' performed by default handler. ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) @@ -544,7 +592,7 @@ Every entry is a list (NAME ADDRESS).") (unhandled-file-name-directory . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) - (write-region . tramp-gvfs-handle-write-region)) + (write-region . tramp-handle-write-region)) "Alist of handler functions for Tramp GVFS method. Operations not mentioned here will be handled by the default Emacs primitives.") @@ -564,7 +612,7 @@ Operations not mentioned here will be handled by the default Emacs primitives.") First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." (unless tramp-gvfs-enabled - (tramp-compat-user-error nil "Package `tramp-gvfs' not supported")) + (tramp-user-error nil "Package `tramp-gvfs' not supported")) (let ((fn (assoc operation tramp-gvfs-file-name-handler-alist))) (if fn (save-match-data (apply (cdr fn) args)) @@ -601,12 +649,24 @@ Return nil for null BYTE-ARRAY." (cond ((and (consp message) (characterp (car message))) (format "%S" (tramp-gvfs-dbus-byte-array-to-string message))) + ((and (consp message) (atom (cdr message))) + (cons (tramp-gvfs-stringify-dbus-message (car message)) + (tramp-gvfs-stringify-dbus-message (cdr message)))) ((consp message) (mapcar 'tramp-gvfs-stringify-dbus-message message)) ((stringp message) (format "%S" message)) (t message))) +(defun tramp-dbus-function (vec func args) + "Apply a D-Bus function FUNC from dbus.el. +The call will be traced by Tramp with trace level 6." + (let (result) + (tramp-message vec 6 "%s" (cons func args)) + (setq result (apply func args)) + (tramp-message vec 6 "%s" result(tramp-gvfs-stringify-dbus-message result)) + result)) + (defmacro with-tramp-dbus-call-method (vec synchronous bus service path interface method &rest args) "Apply a D-Bus call on bus BUS. @@ -615,22 +675,34 @@ If SYNCHRONOUS is non-nil, the call is synchronously. Otherwise, it is an asynchronous call, with `ignore' as callback function. The other arguments have the same meaning as with `dbus-call-method' -or `dbus-call-method-asynchronously'. Additionally, the call -will be traced by Tramp with trace level 6." +or `dbus-call-method-asynchronously'." `(let ((func (if ,synchronous 'dbus-call-method 'dbus-call-method-asynchronously)) (args (append (list ,bus ,service ,path ,interface ,method) - (if ,synchronous (list ,@args) (list 'ignore ,@args)))) - result) - (tramp-message ,vec 6 "%s %s" func args) - (setq result (apply func args)) - (tramp-message ,vec 6 "%s" (tramp-gvfs-stringify-dbus-message result)) - result)) + (if ,synchronous (list ,@args) (list 'ignore ,@args))))) + (tramp-dbus-function ,vec func args))) (put 'with-tramp-dbus-call-method 'lisp-indent-function 2) (put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>")) +(defmacro with-tramp-dbus-get-all-properties + (vec bus service path interface) + "Return all properties of INTERFACE. +The call will be traced by Tramp with trace level 6." + ;; Check, that interface exists at object path. Retrieve properties. + `(when (member + ,interface + (tramp-dbus-function + ,vec 'dbus-introspect-get-interface-names + (list ,bus ,service ,path))) + (tramp-dbus-function + ,vec 'dbus-get-all-properties (list ,bus ,service ,path ,interface)))) + +(put 'with-tramp-dbus-get-all-properties 'lisp-indent-function 1) +(put 'with-tramp-dbus-get-all-properties 'edebug-form-spec '(form symbolp body)) +(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-get-all-properties\\>")) + (defvar tramp-gvfs-dbus-event-vector nil "Current Tramp file name to be used, as vector. It is needed when D-Bus signals or errors arrive, because there @@ -639,7 +711,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 @@ -672,6 +744,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) @@ -735,13 +808,13 @@ file names." (when (and t1 (eq op 'rename)) (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname))) (when t2 (with-parsed-tramp-file-name newname nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)))))))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname)))))))) (defun tramp-gvfs-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -775,8 +848,8 @@ file names." (tramp-error v 'file-error "Couldn't delete non-empty %s" directory))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (unless (tramp-gvfs-send-command v (if (and trash delete-by-moving-to-trash) "gvfs-trash" "gvfs-rm") @@ -790,8 +863,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") @@ -826,14 +899,14 @@ file names." (tramp-get-connection-property v "default-location" "~") nil t localname 1))) ;; Tilde expansion is not possible. - (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + (when (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) (tramp-error v 'file-error "Cannot expand tilde in file `%s'" name)) (unless (tramp-run-real-handler 'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) ;; We do not pass "/..". - (if (string-match "^\\(afp\\|davs?\\|smb\\)$" method) + (if (string-match-p "^\\(afp\\|davs?\\|smb\\)$" method) (when (string-match "^/[^/]+\\(/\\.\\./?\\)" localname) (setq localname (replace-match "/" t t localname 1))) (when (string-match "^/\\.\\./?" localname) @@ -844,8 +917,7 @@ file names." ;; No tilde characters in file name, do normal ;; `expand-file-name' (this does "/./" and "/../"). (tramp-make-tramp-file-name - method user domain host port - (tramp-run-real-handler 'expand-file-name (list localname)))))) + v (tramp-run-real-handler 'expand-file-name (list localname)))))) (defun tramp-gvfs-get-directory-attributes (directory) "Return GVFS attributes association list of all files in DIRECTORY." @@ -925,8 +997,8 @@ If FILE-SYSTEM is non-nil, return file system attributes." (setq filename (directory-file-name (expand-file-name filename))) (with-parsed-tramp-file-name filename nil (setq localname (tramp-compat-file-name-unquote localname)) - (if (or (and (string-match "^\\(afp\\|davs?\\|smb\\)$" method) - (string-match "^/?\\([^/]+\\)$" localname)) + (if (or (and (string-match-p "^\\(afp\\|davs?\\|smb\\)$" method) + (string-match-p "^/?\\([^/]+\\)$" localname)) (string-equal localname "/")) (tramp-gvfs-get-root-attributes filename) (assoc @@ -945,6 +1017,18 @@ If FILE-SYSTEM is non-nil, return file system attributes." (setq dirp (if (equal "directory" (cdr (assoc "type" attributes))) t)) (setq res-symlink-target (cdr (assoc "standard::symlink-target" attributes))) + (when (stringp res-symlink-target) + (setq res-symlink-target + ;; Parse unibyte codes "\xNN". We assume they are + ;; non-ASCII codepoints in the range #x80 through #xff. + ;; Convert them to multibyte. + (decode-coding-string + (replace-regexp-in-string + "\\\\x\\([[:xdigit:]]\\{2\\}\\)" + (lambda (x) + (unibyte-string (string-to-number (match-string 1 x) 16))) + res-symlink-target) + 'utf-8))) ;; ... number links (setq res-numlinks (string-to-number @@ -954,7 +1038,8 @@ If FILE-SYSTEM is non-nil, return file system attributes." (if (eq id-format 'integer) (string-to-number (or (cdr (assoc "unix::uid" attributes)) - (format "%s" tramp-unknown-id-integer))) + (eval-when-compile + (format "%s" tramp-unknown-id-integer)))) (or (cdr (assoc "owner::user" attributes)) (cdr (assoc "unix::uid" attributes)) tramp-unknown-id-string))) @@ -962,7 +1047,8 @@ If FILE-SYSTEM is non-nil, return file system attributes." (if (eq id-format 'integer) (string-to-number (or (cdr (assoc "unix::gid" attributes)) - (format "%s" tramp-unknown-id-integer))) + (eval-when-compile + (format "%s" tramp-unknown-id-integer)))) (or (cdr (assoc "owner::group" attributes)) (cdr (assoc "unix::gid" attributes)) tramp-unknown-id-string))) @@ -1040,31 +1126,15 @@ 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 (with-tramp-file-property v localname "file-executable-p" (tramp-check-cached-permissions v ?x)))) -(defun tramp-gvfs-handle-file-local-copy (filename) - "Like `file-local-copy' for Tramp files." - (with-parsed-tramp-file-name filename nil - (unless (file-exists-p filename) - (tramp-error - v tramp-file-missing - "Cannot make local copy of non-existing file `%s'" filename)) - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) - tmpfile))) - (defun tramp-gvfs-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (unless (save-match-data (string-match "/" filename)) + (unless (string-match-p "/" filename) (all-completions filename (with-parsed-tramp-file-name (expand-file-name directory) nil @@ -1080,9 +1150,10 @@ If FILE-SYSTEM is non-nil, return file system attributes." "Like `file-notify-add-watch' for Tramp files." (setq file-name (expand-file-name file-name)) (with-parsed-tramp-file-name file-name nil - ;; We cannot watch directories, because `gvfs-monitor-dir' is not - ;; supported for gvfs-mounted directories. - (when (file-directory-p file-name) + ;; TODO: We cannot watch directories, because `gio monitor' is not + ;; supported for gvfs-mounted directories. However, + ;; `file-notify-add-watch' uses directories. + (when (or (not (tramp-gvfs-gio-tool-p v)) (file-directory-p file-name)) (tramp-error v 'file-notify-error "Monitoring not supported for `%s'" file-name)) (let* ((default-directory (file-name-directory file-name)) @@ -1097,67 +1168,80 @@ If FILE-SYSTEM is non-nil, return file system attributes." (p (apply 'start-process "gvfs-monitor" (generate-new-buffer " *gvfs-monitor*") - (if (tramp-gvfs-gio-tool-p v) - `("gio" "monitor" ,(tramp-gvfs-url-file-name file-name))) - `("gvfs-monitor-file" (tramp-gvfs-url-file-name file-name))))) + `("gio" "monitor" ,(tramp-gvfs-url-file-name file-name))))) (if (not (processp p)) (tramp-error v 'file-notify-error "Monitoring not supported for `%s'" file-name) (tramp-message v 6 "Run `%s', %S" (mapconcat 'identity (process-command p) " ") p) - (tramp-set-connection-property p "vector" v) + (process-put p 'vector v) (process-put p 'events events) (process-put p 'watch-name localname) (process-put p 'adjust-window-size-function 'ignore) (set-process-query-on-exit-flag p nil) - (set-process-filter p 'tramp-gvfs-monitor-file-process-filter) + (set-process-filter p 'tramp-gvfs-monitor-process-filter) ;; There might be an error if the monitor is not supported. ;; Give the filter a chance to read the output. (tramp-accept-process-output p 1) (unless (process-live-p p) (tramp-error - v 'file-notify-error "Monitoring not supported for `%s'" file-name)) + p 'file-notify-error "Monitoring not supported for `%s'" file-name)) p)))) -(defun tramp-gvfs-monitor-file-process-filter (proc string) +(defun tramp-gvfs-monitor-process-filter (proc string) "Read output from \"gvfs-monitor-file\" and add corresponding \ file-notify events." - (let* ((rest-string (process-get proc 'rest-string)) + (let* ((events (process-get proc 'events)) + (rest-string (process-get proc 'rest-string)) (dd (with-current-buffer (process-buffer proc) default-directory)) (ddu (regexp-quote (tramp-gvfs-url-file-name dd)))) (when rest-string (tramp-message proc 10 "Previous string:\n%s" rest-string)) (tramp-message proc 6 "%S\n%s" proc string) (setq string (concat rest-string string) - ;; Attribute change is returned in unused wording. - string (replace-regexp-in-string - "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string)) - (when (string-match "Monitoring not supported" string) + ;; Fix action names. + string (replace-regexp-in-string + "attributes changed" "attribute-changed" string) + string (replace-regexp-in-string + "changes done" "changes-done-hint" string) + string (replace-regexp-in-string + "renamed to" "moved" string)) + ;; https://bugs.launchpad.net/bugs/1742946 + (when + (string-match-p "Monitoring not supported\\|No locations given" string) (delete-process proc)) (while (string-match - (concat "^[\n\r]*" - "File Monitor Event:[\n\r]+" - "File = \\([^\n\r]+\\)[\n\r]+" - "Event = \\([^[:blank:]]+\\)[\n\r]+") + (eval-when-compile + (concat "^.+:" + "[[:space:]]\\(.+\\):" + "[[:space:]]" (regexp-opt tramp-gio-events t) + "\\([[:space:]]\\(.+\\)\\)?$")) string) + (let ((file (match-string 1 string)) - (action (intern-soft - (replace-regexp-in-string - "_" "-" (downcase (match-string 2 string)))))) + (file1 (match-string 4 string)) + (action (intern-soft (match-string 2 string)))) (setq string (replace-match "" nil nil string)) ;; File names are returned as URL paths. We must convert them. (when (string-match ddu file) (setq file (replace-match dd nil nil file))) - (while (string-match "%\\([0-9A-F]\\{2\\}\\)" file) - (setq file - (replace-match - (char-to-string (string-to-number (match-string 1 file) 16)) - nil nil file))) + (while (string-match-p "%\\([0-9A-F]\\{2\\}\\)" file) + (setq file (url-unhex-string file))) + (when (string-match ddu (or file1 "")) + (setq file1 (replace-match dd nil nil file1))) + (while (string-match-p "%\\([0-9A-F]\\{2\\}\\)" (or file1 "")) + (setq file1 (url-unhex-string file1))) + ;; Remove watch when file or directory to be watched is deleted. + (when (and (member action '(moved deleted)) + (string-equal file (process-get proc 'watch-name))) + (delete-process proc)) ;; Usually, we would add an Emacs event now. Unfortunately, ;; `unread-command-events' does not accept several events at ;; once. Therefore, we apply the callback directly. - (tramp-compat-funcall 'file-notify-callback (list proc action file)))) + (when (member action events) + (tramp-compat-funcall + 'file-notify-callback (list proc action file file1))))) ;; Save rest of the string. (when (zerop (length string)) (setq string nil)) @@ -1175,33 +1259,22 @@ 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))) (free (cdr (assoc "filesystem::free" attr)))) (when (and (stringp size) (stringp used) (stringp free)) - (list (string-to-number (concat size "e0")) - (- (string-to-number (concat size "e0")) - (string-to-number (concat used "e0"))) - (string-to-number (concat free "e0"))))))) - -(defun tramp-gvfs-handle-file-writable-p (filename) - "Like `file-writable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-tramp-file-property v localname "file-writable-p" - (if (file-exists-p filename) - (tramp-check-cached-permissions v ?w) - ;; If file doesn't exist, check if directory is writable. - (and (file-directory-p (file-name-directory filename)) - (file-writable-p (file-name-directory filename))))))) + (list (string-to-number size) + (- (string-to-number size) (string-to-number used)) + (string-to-number free)))))) (defun tramp-gvfs-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." (setq dir (directory-file-name (expand-file-name dir))) (with-parsed-tramp-file-name dir nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (save-match-data (let ((ldir (file-name-directory dir))) ;; Make missing directory parts. "gvfs-mkdir -p ..." does not @@ -1230,54 +1303,12 @@ file-notify events." (tramp-run-real-handler 'rename-file (list filename newname ok-if-already-exists)))) -(defun tramp-gvfs-handle-write-region - (start end filename &optional append visit lockname mustbenew) - "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) - (with-parsed-tramp-file-name filename nil - (when (and mustbenew (file-exists-p filename) - (or (eq mustbenew 'excl) - (not - (y-or-n-p - (format "File %s exists; overwrite anyway? " filename))))) - (tramp-error v 'file-already-exists filename)) - - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (when (and append (file-exists-p filename)) - (copy-file filename tmpfile 'ok)) - ;; We say `no-message' here because we don't want the visited file - ;; modtime data to be clobbered from the temp file. We call - ;; `set-visited-file-modtime' ourselves later on. - (tramp-run-real-handler - 'write-region (list start end tmpfile append 'no-message lockname)) - (condition-case nil - (rename-file tmpfile filename 'ok-if-already-exists) - (error - (delete-file tmpfile) - (tramp-error - v 'file-error "Couldn't write region to `%s'" filename)))) - - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) - - ;; Set file modification time. - (when (or (eq visit t) (stringp visit)) - (set-visited-file-modtime - (tramp-compat-file-attribute-modification-time - (file-attributes filename)))) - - ;; The end. - (when (and (null noninteractive) - (or (eq visit t) (null visit) (stringp visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook))) - ;; File name conversions. (defun tramp-gvfs-url-file-name (filename) "Return FILENAME in URL syntax." - ;; "/" must NOT be hexlified. + ;; "/" must NOT be hexified. (setq filename (tramp-compat-file-name-unquote filename)) (let ((url-unreserved-chars (cons ?/ url-unreserved-chars)) result) @@ -1288,6 +1319,10 @@ file-notify events." (with-parsed-tramp-file-name filename nil (when (string-equal "gdrive" method) (setq method "google-drive")) + (when (string-equal "nextcloud" method) + (setq method "davs" + localname + (concat (tramp-gvfs-get-remote-prefix v) localname))) (when (and user domain) (setq user (concat domain ";" user))) (url-parse-make-urlobj @@ -1312,24 +1347,6 @@ file-notify events." (dbus-unescape-from-identifier (replace-regexp-in-string "^.*/\\([^/]+\\)$" "\\1" object-path))) -(defun tramp-bluez-address (device) - "Return bluetooth device address from a given bluetooth DEVICE name." - (when (stringp device) - (if (string-match tramp-ipv6-regexp device) - (match-string 0 device) - (cadr (assoc device (tramp-bluez-list-devices)))))) - -(defun tramp-bluez-device (address) - "Return bluetooth device name from a given bluetooth device ADDRESS. -ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." - (when (stringp address) - (while (string-match "[][]" address) - (setq address (replace-match "" t t address))) - (let (result) - (dolist (item (tramp-bluez-list-devices) result) - (when (string-match address (cadr item)) - (setq result (car item))))))) - ;; D-Bus GVFS functions. @@ -1361,13 +1378,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (unless (tramp-get-connection-property l "first-password-request" nil) (tramp-clear-passwd l)) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method l-method - tramp-current-user user - tramp-current-domain l-domain - tramp-current-host l-host - tramp-current-port l-port - password (tramp-read-passwd + (setq password (tramp-read-passwd (tramp-get-connection-process l) pw-prompt)) ;; Return result. @@ -1406,7 +1417,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (tramp-get-connection-process v) message ;; In theory, there can be several choices. ;; Until now, there is only the question whether - ;; to accept an unknown host signature. + ;; to accept an unknown host signature or certificate. (with-temp-buffer ;; Preserve message for `progress-reporter'. (with-temp-message "" @@ -1447,6 +1458,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (while (stringp (car elt)) (setq elt (cdr elt))) (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string (cadr elt))) (mount-spec (cl-caddr elt)) + (prefix (tramp-gvfs-dbus-byte-array-to-string (car mount-spec))) (default-location (tramp-gvfs-dbus-byte-array-to-string (cl-cadddr elt))) (method (tramp-gvfs-dbus-byte-array-to-string @@ -1462,34 +1474,37 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (cadr (assoc "port" (cadr mount-spec))))) (ssl (tramp-gvfs-dbus-byte-array-to-string (cadr (assoc "ssl" (cadr mount-spec))))) - (prefix (concat - (tramp-gvfs-dbus-byte-array-to-string - (car mount-spec)) - (tramp-gvfs-dbus-byte-array-to-string - (or (cadr (assoc "share" (cadr mount-spec))) - (cadr (assoc "volume" (cadr mount-spec)))))))) + (uri (tramp-gvfs-dbus-byte-array-to-string + (cadr (assoc "uri" (cadr mount-spec)))))) (when (string-match "^\\(afp\\|smb\\)" method) (setq method (match-string 1 method))) - (when (string-equal "obex" method) - (setq host (tramp-bluez-device host))) (when (and (string-equal "dav" method) (string-equal "true" ssl)) (setq method "davs")) + (when (and (string-equal "davs" method) + (string-match-p + tramp-gvfs-nextcloud-default-prefix-regexp prefix)) + (setq method "nextcloud")) (when (string-equal "google-drive" method) (setq method "gdrive")) - (with-parsed-tramp-file-name - (tramp-make-tramp-file-name method user domain host port "") nil - (tramp-message - v 6 "%s %s" - signal-name (tramp-gvfs-stringify-dbus-message mount-info)) - (tramp-set-file-property v "/" "list-mounts" 'undef) - (if (string-equal (downcase signal-name) "unmounted") - (tramp-flush-file-property v "/") - ;; Set prefix, mountpoint and location. - (unless (string-equal prefix "/") - (tramp-set-file-property v "/" "prefix" prefix)) - (tramp-set-file-property v "/" "fuse-mountpoint" fuse-mountpoint) - (tramp-set-connection-property - v "default-location" default-location))))))) + (when (and (string-equal "http" method) (stringp uri)) + (setq uri (url-generic-parse-url uri) + method (url-type uri) + user (url-user uri) + host (url-host uri) + port (url-portspec uri))) + (when (member method tramp-gvfs-methods) + (with-parsed-tramp-file-name + (tramp-make-tramp-file-name method user domain host port "") nil + (tramp-message + v 6 "%s %s" + signal-name (tramp-gvfs-stringify-dbus-message mount-info)) + (tramp-flush-file-property v "/" "list-mounts") + (if (string-equal (downcase signal-name) "unmounted") + (tramp-flush-file-properties v "/") + ;; Set mountpoint and location. + (tramp-set-file-property v "/" "fuse-mountpoint" fuse-mountpoint) + (tramp-set-connection-property + v "default-location" default-location)))))))) (when tramp-gvfs-enabled (dbus-register-signal @@ -1529,6 +1544,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string (cadr elt))) (mount-spec (cl-caddr elt)) + (prefix (tramp-gvfs-dbus-byte-array-to-string (car mount-spec))) (default-location (tramp-gvfs-dbus-byte-array-to-string (cl-cadddr elt))) (method (tramp-gvfs-dbus-byte-array-to-string @@ -1544,43 +1560,59 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (cadr (assoc "port" (cadr mount-spec))))) (ssl (tramp-gvfs-dbus-byte-array-to-string (cadr (assoc "ssl" (cadr mount-spec))))) - (prefix (concat - (tramp-gvfs-dbus-byte-array-to-string - (car mount-spec)) - (tramp-gvfs-dbus-byte-array-to-string - (or - (cadr (assoc "share" (cadr mount-spec))) - (cadr (assoc "volume" (cadr mount-spec)))))))) + (uri (tramp-gvfs-dbus-byte-array-to-string + (cadr (assoc "uri" (cadr mount-spec))))) + (share (tramp-gvfs-dbus-byte-array-to-string + (or + (cadr (assoc "share" (cadr mount-spec))) + (cadr (assoc "volume" (cadr mount-spec))))))) (when (string-match "^\\(afp\\|smb\\)" method) (setq method (match-string 1 method))) - (when (string-equal "obex" method) - (setq host (tramp-bluez-device host))) (when (and (string-equal "dav" method) (string-equal "true" ssl)) (setq method "davs")) + (when (and (string-equal "davs" method) + (string-match-p + tramp-gvfs-nextcloud-default-prefix-regexp prefix)) + (setq method "nextcloud")) (when (string-equal "google-drive" method) (setq method "gdrive")) - (when (and (string-equal "synce" method) (zerop (length user))) - (setq user (or (tramp-file-name-user vec) ""))) + (when (and (string-equal "http" method) (stringp uri)) + (setq uri (url-generic-parse-url uri) + method (url-type uri) + user (url-user uri) + host (url-host uri) + port (url-portspec uri))) (when (and (string-equal method (tramp-file-name-method vec)) (string-equal user (tramp-file-name-user vec)) (string-equal domain (tramp-file-name-domain vec)) (string-equal host (tramp-file-name-host vec)) (string-equal port (tramp-file-name-port vec)) - (string-match (concat "^" (regexp-quote prefix)) - (tramp-file-name-unquote-localname vec))) - ;; Set prefix, mountpoint and location. - (unless (string-equal prefix "/") - (tramp-set-file-property vec "/" "prefix" prefix)) + (string-match-p (concat "^/" (regexp-quote (or share ""))) + (tramp-file-name-unquote-localname vec))) + ;; Set mountpoint and location. (tramp-set-file-property vec "/" "fuse-mountpoint" fuse-mountpoint) (tramp-set-connection-property vec "default-location" default-location) (throw 'mounted t))))))) +(defun tramp-gvfs-unmount (vec) + "Unmount the object identified by VEC." + (setf (tramp-file-name-localname vec) "/" + (tramp-file-name-hop vec) nil) + (when (tramp-gvfs-connection-mounted-p vec) + (tramp-gvfs-send-command + vec "gvfs-mount" "-u" + (tramp-gvfs-url-file-name (tramp-make-tramp-file-name vec)))) + (while (tramp-gvfs-connection-mounted-p vec) + (read-event nil nil 0.1)) + (tramp-flush-connection-properties vec) + (tramp-flush-connection-properties (tramp-get-connection-process vec))) + (defun tramp-gvfs-mount-spec-entry (key value) "Construct a mount-spec entry to be used in a mount_spec. It was \"a(say)\", but has changed to \"a{sv})\"." - (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature) + (if (string-match-p "^(aya{sv})" tramp-gvfs-mountlocation-signature) (list :dict-entry key (list :variant (tramp-gvfs-dbus-string-to-byte-array value))) (list :struct key (tramp-gvfs-dbus-string-to-byte-array value)))) @@ -1595,7 +1627,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (localname (tramp-file-name-unquote-localname vec)) (share (when (string-match "^/?\\([^/]+\\)" localname) (match-string 1 localname))) - (ssl (if (string-match "^davs" method) "true" "false")) + (ssl (if (string-match-p "^davs\\|^nextcloud" method) "true" "false")) (mount-spec `(:array ,@(cond @@ -1603,11 +1635,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (list (tramp-gvfs-mount-spec-entry "type" "smb-share") (tramp-gvfs-mount-spec-entry "server" host) (tramp-gvfs-mount-spec-entry "share" share))) - ((string-equal "obex" method) - (list (tramp-gvfs-mount-spec-entry "type" method) - (tramp-gvfs-mount-spec-entry - "host" (concat "[" (tramp-bluez-address host) "]")))) - ((string-match "\\`dav" method) + ((string-match-p "^dav\\|^nextcloud" method) (list (tramp-gvfs-mount-spec-entry "type" "dav") (tramp-gvfs-mount-spec-entry "host" host) (tramp-gvfs-mount-spec-entry "ssl" ssl))) @@ -1618,7 +1646,17 @@ It was \"a(say)\", but has changed to \"a{sv})\"." ((string-equal "gdrive" method) (list (tramp-gvfs-mount-spec-entry "type" "google-drive") (tramp-gvfs-mount-spec-entry "host" host))) - (t + ((string-equal "nextcloud" method) + (list (tramp-gvfs-mount-spec-entry "type" "owncloud") + (tramp-gvfs-mount-spec-entry "host" host))) + ((string-match-p "^http" method) + (list (tramp-gvfs-mount-spec-entry "type" "http") + (tramp-gvfs-mount-spec-entry + "uri" + (url-recreate-url + (url-parse-make-urlobj + method user nil host port "/" nil nil t))))) + (t (list (tramp-gvfs-mount-spec-entry "type" method) (tramp-gvfs-mount-spec-entry "host" host)))) ,@(when user @@ -1628,10 +1666,10 @@ It was \"a(say)\", but has changed to \"a{sv})\"." ,@(when port (list (tramp-gvfs-mount-spec-entry "port" port))))) (mount-pref - (if (and (string-match "\\`dav" method) + (if (and (string-match-p "^dav" method) (string-match "^/?[^/]+" localname)) (match-string 0 localname) - "/"))) + (tramp-gvfs-get-remote-prefix vec)))) ;; Return. `(:struct ,(tramp-gvfs-dbus-string-to-byte-array mount-pref) ,mount-spec))) @@ -1643,20 +1681,15 @@ It was \"a(say)\", but has changed to \"a{sv})\"." "The uid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." (with-tramp-connection-property vec (format "uid-%s" id-format) - (let ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (domain (tramp-file-name-domain vec)) - (host (tramp-file-name-host vec)) - (port (tramp-file-name-port vec)) + (let ((user (tramp-file-name-user vec)) (localname (tramp-get-connection-property vec "default-location" nil))) (cond - ((and user (equal id-format 'string)) user) + ((and (equal id-format 'string) user)) (localname (tramp-compat-file-attribute-user-id (file-attributes - (tramp-make-tramp-file-name method user domain host port localname) - id-format))) + (tramp-make-tramp-file-name vec localname) id-format))) ((equal id-format 'integer) tramp-unknown-id-integer) ((equal id-format 'string) tramp-unknown-id-string))))) @@ -1664,25 +1697,34 @@ ID-FORMAT valid values are `string' and `integer'." "The gid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." (with-tramp-connection-property vec (format "gid-%s" id-format) - (let ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (domain (tramp-file-name-domain vec)) - (host (tramp-file-name-host vec)) - (port (tramp-file-name-port vec)) - (localname + (let ((localname (tramp-get-connection-property vec "default-location" nil))) (cond (localname (tramp-compat-file-attribute-group-id (file-attributes - (tramp-make-tramp-file-name method user domain host port localname) - id-format))) + (tramp-make-tramp-file-name vec localname) id-format))) ((equal id-format 'integer) tramp-unknown-id-integer) ((equal id-format 'string) tramp-unknown-id-string))))) (defvar tramp-gvfs-get-remote-uid-gid-in-progress nil "Indication, that remote uid and gid determination is in progress.") +(defun tramp-gvfs-get-remote-prefix (vec) + "The prefix of the remote connection VEC. +This is relevant for GNOME Online Accounts." + (with-tramp-connection-property vec "prefix" + ;; Ensure that GNOME Online Accounts are cached. + (when (member (tramp-file-name-method vec) tramp-goa-methods) + (tramp-get-goa-accounts vec)) + (tramp-get-connection-property + (make-tramp-goa-name + :method (tramp-file-name-method vec) + :user (tramp-file-name-user vec) + :host (tramp-file-name-host vec) + :port (tramp-file-name-port vec)) + "prefix" "/"))) + (defun tramp-gvfs-maybe-open-connection (vec) "Maybe open a connection VEC. Does not do anything if a connection is already open, but re-opens the @@ -1699,24 +1741,22 @@ connection if a previous connection has died for some reason." :name (tramp-buffer-name vec) :buffer (tramp-get-connection-buffer vec) :server t :host 'local :service t :noquery t))) + (process-put p 'vector vec) (set-process-query-on-exit-flag p nil))) (unless (tramp-gvfs-connection-mounted-p vec) - (let* ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (domain (tramp-file-name-domain vec)) - (host (tramp-file-name-host vec)) - (port (tramp-file-name-port vec)) - (localname (tramp-file-name-unquote-localname vec)) - (object-path - (tramp-gvfs-object-path - (tramp-make-tramp-file-name method user domain host port "")))) + (let ((method (tramp-file-name-method vec)) + (user (tramp-file-name-user vec)) + (host (tramp-file-name-host vec)) + (localname (tramp-file-name-unquote-localname vec)) + (object-path + (tramp-gvfs-object-path (tramp-make-tramp-file-name vec 'noloc)))) (when (and (string-equal method "afp") (string-equal localname "/")) (tramp-error vec 'file-error "Filename must contain an AFP volume")) - (when (and (string-match method "davs?") + (when (and (string-match-p "davs?" method) (string-equal localname "/")) (tramp-error vec 'file-error "Filename must contain a WebDAV share")) @@ -1744,7 +1784,8 @@ connection if a previous connection has died for some reason." tramp-gvfs-interface-mountoperation "AskPassword" 'tramp-gvfs-handler-askpassword) - ;; There could be a callback of "askQuestion" when adding fingerprint. + ;; There could be a callback of "askQuestion" when adding + ;; fingerprints or checking certificates. (dbus-register-method :session dbus-service-emacs object-path tramp-gvfs-interface-mountoperation "askQuestion" @@ -1756,7 +1797,7 @@ connection if a previous connection has died for some reason." ;; The call must be asynchronously, because of the "askPassword" ;; or "askQuestion" callbacks. - (if (string-match "(so)$" tramp-gvfs-mountlocation-signature) + (if (string-match-p "(so)$" tramp-gvfs-mountlocation-signature) (with-tramp-dbus-call-method vec nil :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation @@ -1791,6 +1832,9 @@ connection if a previous connection has died for some reason." (tramp-get-file-property vec "/" "fuse-mountpoint" "") "/") (tramp-error vec 'file-error "FUSE mount denied")) + ;; Save the password. + (ignore-errors (funcall tramp-password-save-function)) + ;; Set connection-local variables. (tramp-set-connection-local-variables vec) @@ -1834,86 +1878,64 @@ 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. - -(defun tramp-bluez-list-devices () - "Return all discovered bluetooth devices as list. -Every entry is a list (NAME ADDRESS). - -If `tramp-bluez-discover-devices-timeout' is an integer, and the last -discovery happened more time before indicated there, a rescan will be -started, which lasts some ten seconds. Otherwise, cached results will -be used." - ;; Reset the scanned devices list if time has passed. - (and (integerp tramp-bluez-discover-devices-timeout) - (integerp tramp-bluez-discovery) - (> (tramp-time-diff (current-time) tramp-bluez-discovery) - tramp-bluez-discover-devices-timeout) - (setq tramp-bluez-devices nil)) - - ;; Rescan if needed. - (unless tramp-bluez-devices - (let ((object-path - (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t - :system tramp-bluez-service "/" - tramp-bluez-interface-manager "DefaultAdapter"))) - (setq tramp-bluez-devices nil - tramp-bluez-discovery t) - (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector nil - :system tramp-bluez-service object-path - tramp-bluez-interface-adapter "StartDiscovery") - (while tramp-bluez-discovery - (read-event nil nil 0.1)))) - (setq tramp-bluez-discovery (current-time)) - (tramp-message tramp-gvfs-dbus-event-vector 10 "%s" tramp-bluez-devices) - tramp-bluez-devices) - -(defun tramp-bluez-property-changed (property value) - "Signal handler for the \"org.bluez.Adapter.PropertyChanged\" signal." - (tramp-message tramp-gvfs-dbus-event-vector 6 "%s %s" property value) - (cond - ((string-equal property "Discovering") - (unless (car value) - ;; "Discovering" FALSE means discovery run has been completed. - ;; We stop it, because we don't need another run. - (setq tramp-bluez-discovery nil) - (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t - :system tramp-bluez-service (dbus-event-path-name last-input-event) - tramp-bluez-interface-adapter "StopDiscovery"))))) - -(when tramp-gvfs-enabled - (dbus-register-signal - :system nil nil tramp-bluez-interface-adapter "PropertyChanged" - 'tramp-bluez-property-changed)) - -(defun tramp-bluez-device-found (device args) - "Signal handler for the \"org.bluez.Adapter.DeviceFound\" signal." - (tramp-message tramp-gvfs-dbus-event-vector 6 "%s %s" device args) - (let ((alias (car (cadr (assoc "Alias" args)))) - (address (car (cadr (assoc "Address" args))))) - ;; Maybe we shall check the device class for being a proper - ;; device, and call also SDP in order to find the obex service. - (add-to-list 'tramp-bluez-devices (list alias address)))) - -(when tramp-gvfs-enabled - (dbus-register-signal - :system nil nil tramp-bluez-interface-adapter "DeviceFound" - 'tramp-bluez-device-found)) - -(defun tramp-bluez-parse-device-names (_ignore) - "Return a list of (nil host) tuples allowed to access." - (mapcar - (lambda (x) (list nil (car x))) - (tramp-bluez-list-devices))) - -;; Add completion function for OBEX method. -(when (and tramp-gvfs-enabled - (member tramp-bluez-service (dbus-list-known-names :system))) - (tramp-set-completion-function - "obex" '((tramp-bluez-parse-device-names "")))) +;; D-Bus GNOME Online Accounts functions. + +(defun tramp-get-goa-accounts (vec) + "Retrieve GNOME Online Accounts, and cache them. +The hash key is a `tramp-goa-name' structure. The value is an +alist of the properties of `tramp-goa-interface-account' and +`tramp-goa-interface-files' of the corresponding GNOME online +account. Additionally, a property \"prefix\" is added. +VEC is used only for traces." + (dolist + (object-path + (mapcar + 'car + (tramp-dbus-function + vec 'dbus-get-all-managed-objects + `(:session ,tramp-goa-service ,tramp-goa-path)))) + (let* ((account-properties + (with-tramp-dbus-get-all-properties vec + :session tramp-goa-service object-path + tramp-goa-interface-account)) + (files-properties + (with-tramp-dbus-get-all-properties vec + :session tramp-goa-service object-path + tramp-goa-interface-files)) + (identity + (or (cdr (assoc "PresentationIdentity" account-properties)) "")) + key) + ;; Only accounts which matter. + (when (and + (not (cdr (assoc "FilesDisabled" account-properties))) + (member + (cdr (assoc "ProviderType" account-properties)) + '("google" "owncloud")) + (string-match tramp-goa-identity-regexp identity)) + (setq key (make-tramp-goa-name + :method (cdr (assoc "ProviderType" account-properties)) + :user (match-string 1 identity) + :host (match-string 2 identity) + :port (match-string 3 identity))) + (when (string-equal (tramp-goa-name-method key) "google") + (setf (tramp-goa-name-method key) "gdrive")) + (when (string-equal (tramp-goa-name-method key) "owncloud") + (setf (tramp-goa-name-method key) "nextcloud")) + ;; Cache all properties. + (dolist (prop (nconc account-properties files-properties)) + (tramp-set-connection-property key (car prop) (cdr prop))) + ;; Cache "prefix". + (tramp-message + vec 10 "%s prefix %s" key + (tramp-set-connection-property + key "prefix" + (directory-file-name + (url-filename + (url-generic-parse-url + (tramp-get-connection-property key "Uri" "file:///")))))))))) ;; D-Bus zeroconf functions. @@ -1997,41 +2019,6 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." (tramp-set-completion-function "smb" '((tramp-gvfs-parse-device-names "_smb._tcp")))))))) - -;; D-Bus SYNCE functions. - -(defun tramp-synce-list-devices () - "Return all discovered synce devices as list. -They are retrieved from the hal daemon." - (let (tramp-synce-devices) - (dolist (device - (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t - :system tramp-hal-service tramp-hal-path-manager - tramp-hal-interface-manager "GetAllDevices")) - (when (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t - :system tramp-hal-service device tramp-hal-interface-device - "PropertyExists" "sync.plugin") - (let ((prop - (with-tramp-dbus-call-method - tramp-gvfs-dbus-event-vector t - :system tramp-hal-service device tramp-hal-interface-device - "GetPropertyString" "pda.pocketpc.name"))) - (unless (member prop tramp-synce-devices) - (push prop tramp-synce-devices))))) - (tramp-message tramp-gvfs-dbus-event-vector 10 "%s" tramp-synce-devices) - tramp-synce-devices)) - -(defun tramp-synce-parse-device-names (_ignore) - "Return a list of (nil host) tuples allowed to access." - (mapcar - (lambda (x) (list nil x)) - (tramp-synce-list-devices))) - -;; Add completion function for SYNCE method. -(when tramp-gvfs-enabled - (tramp-set-completion-function - "synce" '((tramp-synce-parse-device-names "")))) - (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-gvfs 'force))) @@ -2040,15 +2027,14 @@ They are retrieved from the hal daemon." ;;; TODO: +;; * (Customizable) unmount when exiting Emacs. See tramp-archive.el. +;; ;; * Host name completion for existing mount points (afp-server, -;; smb-server) or via smb-network. +;; smb-server, google-drive, nextcloud) or via smb-network or network. ;; ;; * Check, how two shares of the same SMB server can be mounted in ;; parallel. ;; -;; * Apply SDP on bluetooth devices, in order to filter out obex -;; capability. -;; -;; * Implement obex for other serial communication but bluetooth. +;; * What's up with ftps dns-sd afc admin computer? ;;; tramp-gvfs.el ends here diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el new file mode 100644 index 00000000000..5ea42c07bf2 --- /dev/null +++ b/lisp/net/tramp-rclone.el @@ -0,0 +1,608 @@ +;;; tramp-rclone.el --- Tramp access functions to cloud storages -*- lexical-binding:t -*- + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; Keywords: comm, processes +;; Package: tramp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; rclone is a command line program to sync files and directories to +;; and from cloud storages. Tramp uses its mount utility to access +;; files and directories there. The configuration of rclone for +;; different storage systems is performed outside Tramp, see rclone(1). + +;; A remote file under rclone control has the form +;; "/rclone:<remote>:/path/to/file". <remote> is the name of a +;; storage system in rclone's configuration. Therefore, such a remote +;; file name does not know of any user or port specification. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'tramp) + +;;;###tramp-autoload +(defconst tramp-rclone-method "rclone" + "When this method name is used, forward all calls to rclone mounts.") + +;;;###tramp-autoload +(defcustom tramp-rclone-program "rclone" + "Name of the rclone program." + :group 'tramp + :version "27.1" + :type 'string) + +;;;###tramp-autoload +(add-to-list + 'tramp-methods + `(,tramp-rclone-method + (tramp-mount-args nil) + (tramp-copyto-args nil) + (tramp-moveto-args nil) + (tramp-about-args ("--full")))) + +;;;###tramp-autoload +(eval-after-load 'tramp + '(tramp-set-completion-function + tramp-rclone-method '((tramp-rclone-parse-device-names "")))) + + +;; New handlers should be added here. +;;;###tramp-autoload +(defconst tramp-rclone-file-name-handler-alist + '((access-file . ignore) + (add-name-to-file . tramp-handle-add-name-to-file) + ;; `byte-compiler-base-file-name' performed by default handler. + ;; `copy-directory' performed by default handler. + (copy-file . tramp-rclone-handle-copy-file) + (delete-directory . tramp-rclone-handle-delete-directory) + (delete-file . tramp-rclone-handle-delete-file) + ;; `diff-latest-backup-file' performed by default handler. + (directory-file-name . tramp-handle-directory-file-name) + (directory-files . tramp-rclone-handle-directory-files) + (directory-files-and-attributes + . tramp-handle-directory-files-and-attributes) + (dired-compress-file . ignore) + (dired-uncache . tramp-handle-dired-uncache) + (exec-path . ignore) + (expand-file-name . tramp-handle-expand-file-name) + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) + (file-acl . ignore) + (file-attributes . tramp-rclone-handle-file-attributes) + (file-directory-p . tramp-handle-file-directory-p) + (file-equal-p . tramp-handle-file-equal-p) + (file-executable-p . tramp-rclone-handle-file-executable-p) + (file-exists-p . tramp-handle-file-exists-p) + (file-in-directory-p . tramp-handle-file-in-directory-p) + (file-local-copy . tramp-handle-file-local-copy) + (file-modes . tramp-handle-file-modes) + (file-name-all-completions . tramp-rclone-handle-file-name-all-completions) + (file-name-as-directory . tramp-handle-file-name-as-directory) + (file-name-case-insensitive-p . tramp-handle-file-name-case-insensitive-p) + (file-name-completion . tramp-handle-file-name-completion) + (file-name-directory . tramp-handle-file-name-directory) + (file-name-nondirectory . tramp-handle-file-name-nondirectory) + ;; `file-name-sans-versions' performed by default handler. + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) + (file-notify-add-watch . ignore) + (file-notify-rm-watch . ignore) + (file-notify-valid-p . ignore) + (file-ownership-preserved-p . ignore) + (file-readable-p . tramp-rclone-handle-file-readable-p) + (file-regular-p . tramp-handle-file-regular-p) + (file-remote-p . tramp-handle-file-remote-p) + (file-selinux-context . tramp-handle-file-selinux-context) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-system-info . tramp-rclone-handle-file-system-info) + (file-truename . tramp-handle-file-truename) + (file-writable-p . tramp-handle-file-writable-p) + (find-backup-file-name . tramp-handle-find-backup-file-name) + ;; `get-file-buffer' performed by default handler. + (insert-directory . tramp-handle-insert-directory) + (insert-file-contents . tramp-handle-insert-file-contents) + (load . tramp-handle-load) + (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) + (make-directory . tramp-rclone-handle-make-directory) + (make-directory-internal . ignore) + (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-file . ignore) + (rename-file . tramp-rclone-handle-rename-file) + (set-file-acl . ignore) + (set-file-modes . ignore) + (set-file-selinux-context . ignore) + (set-file-times . ignore) + (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) + (shell-command . ignore) + (start-file-process . ignore) + (substitute-in-file-name . tramp-handle-substitute-in-file-name) + (temporary-file-directory . tramp-handle-temporary-file-directory) + (unhandled-file-name-directory . ignore) + (vc-registered . ignore) + (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (write-region . tramp-handle-write-region)) + "Alist of handler functions for Tramp RCLONE method. +Operations not mentioned here will be handled by the default Emacs primitives.") + +;; It must be a `defsubst' in order to push the whole code into +;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. +;;;###tramp-autoload +(defsubst tramp-rclone-file-name-p (filename) + "Check if it's a filename for rclone." + (and (tramp-tramp-file-p filename) + (string= (tramp-file-name-method (tramp-dissect-file-name filename)) + tramp-rclone-method))) + +;;;###tramp-autoload +(defun tramp-rclone-file-name-handler (operation &rest args) + "Invoke the rclone handler for OPERATION. +First arg specifies the OPERATION, second arg is a list of arguments to +pass to the OPERATION." + (let ((fn (assoc operation tramp-rclone-file-name-handler-alist))) + (if fn + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args)))) + +;;;###tramp-autoload +(tramp-register-foreign-file-name-handler + 'tramp-rclone-file-name-p 'tramp-rclone-file-name-handler) + +;;;###tramp-autoload +(defun tramp-rclone-parse-device-names (_ignore) + "Return a list of (nil host) tuples allowed to access." + (with-tramp-connection-property nil "rclone-device-names" + (with-timeout (10) + (with-temp-buffer + ;; `call-process' does not react on timer under MS Windows. + ;; That's why we use `start-process'. + (let ((p (start-process + tramp-rclone-program (current-buffer) + tramp-rclone-program "listremotes")) + (v (make-tramp-file-name :method tramp-rclone-method)) + result) + (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " ")) + (process-put p 'adjust-window-size-function 'ignore) + (set-process-query-on-exit-flag p nil) + (while (process-live-p p) + (accept-process-output p 0.1)) + (accept-process-output p 0.1) + (tramp-message v 6 "\n%s" (buffer-string)) + (goto-char (point-min)) + (while (search-forward-regexp "^\\(\\S-+\\):$" nil t) + (push (list nil (match-string 1)) result)) + result))))) + + +;; File name primitives. + +(defun tramp-rclone-do-copy-or-rename-file + (op filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Copy or rename a remote file. +OP must be `copy' or `rename' and indicates the operation to perform. +FILENAME specifies the file to copy or rename, NEWNAME is the name of +the new file (for copy) or the new name of the file (for rename). +OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already. +KEEP-DATE means to make sure that NEWNAME has the same timestamp +as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep +the uid and gid if both files are on the same host. +PRESERVE-EXTENDED-ATTRIBUTES is ignored. + +This function is invoked by `tramp-rclone-handle-copy-file' and +`tramp-rclone-handle-rename-file'. It is an error if OP is neither +of `copy' and `rename'. FILENAME and NEWNAME must be absolute +file names." + (unless (memq op '(copy rename)) + (error "Unknown operation `%s', must be `copy' or `rename'" op)) + + (setq filename (file-truename filename)) + (if (file-directory-p filename) + (progn + (copy-directory filename newname keep-date t) + (when (eq op 'rename) (delete-directory filename 'recursive))) + + (let ((t1 (tramp-tramp-file-p filename)) + (t2 (tramp-tramp-file-p newname)) + (rclone-operation (if (eq op 'copy) "copyto" "moveto")) + (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) + + (with-parsed-tramp-file-name (if t1 filename newname) nil + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + + (if (or (and t1 (not (tramp-rclone-file-name-p filename))) + (and t2 (not (tramp-rclone-file-name-p newname)))) + + ;; We cannot copy or rename directly. + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (if (eq op 'copy) + (copy-file + filename tmpfile t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file filename tmpfile t)) + (rename-file tmpfile newname ok-if-already-exists)) + + ;; Direct action. + (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) + (unless (zerop + (tramp-rclone-send-command + v rclone-operation + (tramp-rclone-remote-file-name filename) + (tramp-rclone-remote-file-name newname))) + (tramp-error + v 'file-error + "Error %s `%s' `%s'" msg-operation filename newname))) + + (when (and t1 (eq op 'rename)) + (with-parsed-tramp-file-name filename v1 + (tramp-flush-file-properties + v1 (file-name-directory v1-localname)) + (tramp-flush-file-properties v1 v1-localname) + (when (tramp-rclone-file-name-p filename) + (tramp-rclone-flush-directory-cache v1) + ;; The mount point's directory cache might need time + ;; to flush. + (while (file-exists-p filename) + (tramp-flush-file-properties + v1 (file-name-directory v1-localname)) + (tramp-flush-file-properties v1 v1-localname))))) + + (when t2 + (with-parsed-tramp-file-name newname v2 + (tramp-flush-file-properties + v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname) + (when (tramp-rclone-file-name-p newname) + (tramp-rclone-flush-directory-cache v2) + ;; The mount point's directory cache might need time + ;; to flush. + (while (not (file-exists-p newname)) + (tramp-flush-file-properties + v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname)))))))))) + +(defun tramp-rclone-handle-copy-file + (filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Like `copy-file' for Tramp files." + (setq filename (expand-file-name filename)) + (setq newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-rclone-do-copy-or-rename-file + 'copy filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + (tramp-run-real-handler + 'copy-file + (list filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes)))) + +(defun tramp-rclone-handle-delete-directory + (directory &optional recursive trash) + "Like `delete-directory' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name directory) nil + (delete-directory (tramp-rclone-local-file-name directory) recursive trash) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) + (tramp-rclone-flush-directory-cache v))) + +(defun tramp-rclone-handle-delete-file (filename &optional trash) + "Like `delete-file' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (delete-file (tramp-rclone-local-file-name filename) trash) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (tramp-rclone-flush-directory-cache v))) + +(defun tramp-rclone-handle-directory-files + (directory &optional full match nosort) + "Like `directory-files' for Tramp files." + (when (file-directory-p directory) + (setq directory (file-name-as-directory (expand-file-name directory))) + (with-parsed-tramp-file-name directory nil + (let ((result + (directory-files + (tramp-rclone-local-file-name directory) full match))) + ;; Massage the result. + (when full + (let ((local (concat "^" (regexp-quote (tramp-rclone-mount-point v)))) + (remote (funcall (if (tramp-compat-file-name-quoted-p directory) + 'tramp-compat-file-name-quote 'identity) + (file-remote-p directory)))) + (setq result + (mapcar + (lambda (x) (replace-regexp-in-string local remote x)) + result)))) + ;; Some storage systems do not return "." and "..". + (dolist (item '(".." ".")) + (when (and (string-match-p (or match (regexp-quote item)) item) + (not + (member (if full (setq item (concat directory item)) item) + result))) + (setq result (cons item result)))) + ;; Return result. + (if nosort result (sort result 'string<)))))) + +(defun tramp-rclone-handle-file-attributes (filename &optional id-format) + "Like `file-attributes' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property + v localname (format "file-attributes-%s" id-format) + (file-attributes (tramp-rclone-local-file-name filename) id-format)))) + +(defun tramp-rclone-handle-file-executable-p (filename) + "Like `file-executable-p' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property v localname "file-executable-p" + (file-executable-p (tramp-rclone-local-file-name filename))))) + +(defun tramp-rclone-handle-file-name-all-completions (filename directory) + "Like `file-name-all-completions' for Tramp files." + (all-completions + filename + (delete-dups + (append + (file-name-all-completions + filename (tramp-rclone-local-file-name directory)) + ;; Some storage systems do not return "." and "..". + (let (result) + (dolist (item '(".." ".") result) + (when (string-prefix-p filename item) + (catch 'match + (dolist (elt completion-regexp-list) + (unless (string-match-p elt item) (throw 'match nil))) + (setq result (cons (concat item "/") result)))))))))) + +(defun tramp-rclone-handle-file-readable-p (filename) + "Like `file-readable-p' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property v localname "file-readable-p" + (file-readable-p (tramp-rclone-local-file-name filename))))) + +(defun tramp-rclone-handle-file-system-info (filename) + "Like `file-system-info' for Tramp files." + (ignore-errors + (unless (file-directory-p filename) + (setq filename (file-name-directory filename))) + (with-parsed-tramp-file-name (expand-file-name filename) nil + (tramp-message v 5 "file system info: %s" localname) + (tramp-rclone-send-command v "about" (concat host ":")) + (with-current-buffer (tramp-get-connection-buffer v) + (let (total used free) + (goto-char (point-min)) + (while (not (eobp)) + (when (looking-at "Total: [[:space:]]+\\([[:digit:]]+\\)") + (setq total (string-to-number (match-string 1)))) + (when (looking-at "Used: [[:space:]]+\\([[:digit:]]+\\)") + (setq used (string-to-number (match-string 1)))) + (when (looking-at "Free: [[:space:]]+\\([[:digit:]]+\\)") + (setq free (string-to-number (match-string 1)))) + (forward-line)) + (when used + ;; The used number of bytes is not part of the result. As + ;; side effect, we store it as file property. + (tramp-set-file-property v localname "used-bytes" used)) + ;; Result. + (when (and total free) + (list total free (- total free)))))))) + +(defun tramp-rclone-handle-insert-directory + (filename switches &optional wildcard full-directory-p) + "Like `insert-directory' for Tramp files." + (insert-directory + (tramp-rclone-local-file-name filename) switches wildcard full-directory-p) + (goto-char (point-min)) + (while (search-forward (tramp-rclone-local-file-name filename) nil 'noerror) + (replace-match filename))) + +(defun tramp-rclone-handle-insert-file-contents + (filename &optional visit beg end replace) + "Like `insert-file-contents' for Tramp files." + (let ((result + (insert-file-contents + (tramp-rclone-local-file-name filename) visit beg end replace))) + (prog1 + (list (expand-file-name filename) (cadr result)) + (when visit (setq buffer-file-name filename))))) + +(defun tramp-rclone-handle-make-directory (dir &optional parents) + "Like `make-directory' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name dir) nil + (make-directory (tramp-rclone-local-file-name dir) parents) + ;; When PARENTS is non-nil, DIR could be a chain of non-existent + ;; directories a/b/c/... Instead of checking, we simply flush the + ;; whole file cache. + (tramp-flush-file-properties v localname) + (tramp-flush-directory-properties + v (if parents "/" (file-name-directory localname))) + (tramp-rclone-flush-directory-cache v))) + +(defun tramp-rclone-handle-rename-file + (filename newname &optional ok-if-already-exists) + "Like `rename-file' for Tramp files." + (setq filename (expand-file-name filename)) + (setq newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-rclone-do-copy-or-rename-file + 'rename filename newname ok-if-already-exists + 'keep-date 'preserve-uid-gid) + (tramp-run-real-handler + 'rename-file (list filename newname ok-if-already-exists)))) + + +;; File name conversions. + +(defun tramp-rclone-mount-point (vec) + "Return local mount point of VEC." + (expand-file-name + (concat + tramp-temp-name-prefix (tramp-file-name-method vec) + "." (tramp-file-name-host vec)) + (tramp-compat-temporary-file-directory))) + +(defun tramp-rclone-mounted-p (vec) + "Check, whether storage system determined by VEC is mounted." + (when (tramp-get-connection-process vec) + ;; We cannot use `with-connection-property', because we don't want + ;; to cache a nil result. + (or (tramp-get-connection-property + (tramp-get-connection-process vec) "mounted" nil) + (tramp-set-connection-property + (tramp-get-connection-process vec) "mounted" + (let* ((default-directory temporary-file-directory) + (mount (shell-command-to-string "mount -t fuse.rclone"))) + (tramp-message vec 6 "%s" "mount -t fuse.rclone") + (tramp-message vec 6 "\n%s" mount) + (when (string-match + (format + "^\\(%s:\\S-*\\)" (regexp-quote (tramp-file-name-host vec))) + mount) + (match-string 1 mount))))))) + +(defun tramp-rclone-flush-directory-cache (vec) + "Flush directory cache of VEC mount." + (let ((rclone-pid + ;; Identify rclone process. + (when (tramp-get-connection-process vec) + (with-tramp-connection-property + (tramp-get-connection-process vec) "rclone-pid" + (catch 'pid + (dolist (pid (list-system-processes)) ;; "pidof rclone" ? + (and (string-match-p + (regexp-quote + (format "rclone mount %s:" (tramp-file-name-host vec))) + (or (cdr (assoc 'args (process-attributes pid))) "")) + (throw 'pid pid)))))))) + ;; Send a SIGHUP in order to flush directory cache. + (when rclone-pid + (tramp-message + vec 6 "Send SIGHUP %d: %s" + rclone-pid (cdr (assoc 'args (process-attributes rclone-pid)))) + (signal-process rclone-pid 'SIGHUP)))) + +(defun tramp-rclone-local-file-name (filename) + "Return local mount name of FILENAME." + (setq filename (tramp-compat-file-name-unquote (expand-file-name filename))) + (with-parsed-tramp-file-name filename nil + ;; As long as we call `tramp-rclone-maybe-open-connection' here, + ;; we cache the result. + (with-tramp-file-property v localname "local-file-name" + (tramp-rclone-maybe-open-connection v) + (let ((quoted (tramp-compat-file-name-quoted-p localname)) + (localname (tramp-compat-file-name-unquote localname))) + (funcall + (if quoted 'tramp-compat-file-name-quote 'identity) + (expand-file-name + (if (file-name-absolute-p localname) + (substring localname 1) localname) + (tramp-rclone-mount-point v))))))) + +(defun tramp-rclone-remote-file-name (filename) + "Return FILENAME as used in the `rclone' command." + (setq filename (tramp-compat-file-name-unquote (expand-file-name filename))) + (if (tramp-rclone-file-name-p filename) + (with-parsed-tramp-file-name filename nil + ;; As long as we call `tramp-rclone-maybe-open-connection' here, + ;; we cache the result. + (with-tramp-file-property v localname "remote-file-name" + (tramp-rclone-maybe-open-connection v) + ;; TODO: This shall be handled by `expand-file-name'. + (setq localname + (replace-regexp-in-string "^\\." "" (or localname ""))) + (format "%s%s" (tramp-rclone-mounted-p v) localname))) + ;; It is a local file name. + filename)) + +(defun tramp-rclone-maybe-open-connection (vec) + "Maybe open a connection VEC. +Does not do anything if a connection is already open, but re-opens the +connection if a previous connection has died for some reason." + (let ((host (tramp-file-name-host vec))) + (when (rassoc `(,host) (tramp-rclone-parse-device-names nil)) + (if (zerop (length host)) + (tramp-error vec 'file-error "Storage %s not connected" host)) + + ;; We need a process bound to the connection buffer. Therefore, + ;; we create a dummy process. Maybe there is a better solution? + (unless (get-buffer-process (tramp-get-connection-buffer vec)) + (let ((p (make-network-process + :name (tramp-buffer-name vec) + :buffer (tramp-get-connection-buffer vec) + :server t :host 'local :service t :noquery t))) + (process-put p 'vector vec) + (set-process-query-on-exit-flag p nil) + + ;; Set connection-local variables. + (tramp-set-connection-local-variables vec))) + + ;; Create directory. + (unless (file-directory-p (tramp-rclone-mount-point vec)) + (make-directory (tramp-rclone-mount-point vec) 'parents)) + + ;; Mount. This command does not return, so we use 0 as + ;; DESTINATION of `tramp-call-process'. + (unless (tramp-rclone-mounted-p vec) + (apply + 'tramp-call-process + vec tramp-rclone-program nil 0 nil + (delq nil + `("mount" ,(concat host ":/") + ,(tramp-rclone-mount-point vec) + ;; This could be nil. + ,(tramp-get-method-parameter vec 'tramp-mount-args)))) + (while (not (file-exists-p (tramp-make-tramp-file-name vec 'localname))) + (tramp-cleanup-connection vec 'keep-debug 'keep-password))))) + + ;; In `tramp-check-cached-permissions', the connection properties + ;; {uig,gid}-{integer,string} are used. We set them to proper values. + (with-tramp-connection-property + vec "uid-integer" (tramp-get-local-uid 'integer)) + (with-tramp-connection-property + vec "gid-integer" (tramp-get-local-gid 'integer)) + (with-tramp-connection-property + vec "uid-string" (tramp-get-local-uid 'string)) + (with-tramp-connection-property + vec "gid-string" (tramp-get-local-gid 'string))) + +(defun tramp-rclone-send-command (vec &rest args) + "Send the COMMAND to connection VEC." + (with-current-buffer (tramp-get-connection-buffer vec) + (erase-buffer) + (let ((flags (tramp-get-method-parameter + vec (intern (format "tramp-%s-args" (car args)))))) + (apply 'tramp-call-process + vec tramp-rclone-program nil t nil (append args flags))))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-rclone 'force))) + +(provide 'tramp-rclone) + +;;; TODO: + +;; * If possible, get rid of "rclone mount". Maybe it is more +;; performant then. + +;;; tramp-rclone.el ends here diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index c304fcb7aa3..a6e9d299a87 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -27,6 +27,7 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) (require 'tramp) ;; Pacify byte-compiler. @@ -270,14 +271,13 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-args ("-c")) (tramp-connection-timeout 10))) ;;;###tramp-autoload -(add-to-list - 'tramp-methods - '("sg" - (tramp-login-program "sg") - (tramp-login-args (("-") ("%u"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-args ("-c")) - (tramp-connection-timeout 10))) +(add-to-list 'tramp-methods + '("sg" + (tramp-login-program "sg") + (tramp-login-args (("-") ("%u"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10))) ;;;###tramp-autoload (add-to-list 'tramp-methods '("sudo" @@ -291,7 +291,8 @@ The string is used in `tramp-methods'.") (tramp-remote-shell "/bin/sh") (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) - (tramp-connection-timeout 10))) + (tramp-connection-timeout 10) + (tramp-session-timeout 300))) ;;;###tramp-autoload (add-to-list 'tramp-methods '("doas" @@ -299,7 +300,8 @@ The string is used in `tramp-methods'.") (tramp-login-args (("-u" "%u") ("-s"))) (tramp-remote-shell "/bin/sh") (tramp-remote-shell-args ("-c")) - (tramp-connection-timeout 10))) + (tramp-connection-timeout 10) + (tramp-session-timeout 300))) ;;;###tramp-autoload (add-to-list 'tramp-methods '("ksu" @@ -321,7 +323,6 @@ The string is used in `tramp-methods'.") (add-to-list 'tramp-methods `("plink" (tramp-login-program "plink") - ;; ("%h") must be a single element, see `tramp-compute-multi-hops'. (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t") ("%h") ("\"") (,(format @@ -694,7 +695,7 @@ else $uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; printf( - \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) -1)\\n\", + \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u %%u t %%u -1)\\n\", $type, $stat[3], $uid, @@ -707,8 +708,7 @@ printf( $stat[10] & 0xffff, $stat[7], $stat[2], - $stat[1] >> 16 & 0xffff, - $stat[1] & 0xffff + $stat[1] );' \"$1\" \"$2\" 2>/dev/null" "Perl script to produce output suitable for use with `file-attributes' on the remote file system. @@ -945,6 +945,7 @@ od -v -t x1 -A n </dev/null && \ busybox awk '{}' </dev/null" "Test command for checking `tramp-awk-encode' and `tramp-awk-decode'.") +;;;###tramp-autoload (defconst tramp-stat-marker "/////" "Marker in stat commands for file attributes.") @@ -954,15 +955,16 @@ busybox awk '{}' </dev/null" (defconst tramp-vc-registered-read-file-names "echo \"(\" while read file; do + quoted=`echo \"$file\" | sed -e \"s/\\\"/\\\\\\\\\\\\\\\\\\\"/\"` if %s \"$file\"; then - echo \"(\\\"$file\\\" \\\"file-exists-p\\\" t)\" + echo \"(\\\"$quoted\\\" \\\"file-exists-p\\\" t)\" else - echo \"(\\\"$file\\\" \\\"file-exists-p\\\" nil)\" + echo \"(\\\"$quoted\\\" \\\"file-exists-p\\\" nil)\" fi if %s \"$file\"; then - echo \"(\\\"$file\\\" \\\"file-readable-p\\\" t)\" + echo \"(\\\"$quoted\\\" \\\"file-readable-p\\\" t)\" else - echo \"(\\\"$file\\\" \\\"file-readable-p\\\" nil)\" + echo \"(\\\"$quoted\\\" \\\"file-readable-p\\\" nil)\" fi done echo \")\"" @@ -989,6 +991,7 @@ of command line.") . tramp-sh-handle-directory-files-and-attributes) (dired-compress-file . tramp-sh-handle-dired-compress-file) (dired-uncache . tramp-handle-dired-uncache) + (exec-path . tramp-sh-handle-exec-path) (expand-file-name . tramp-sh-handle-expand-file-name) (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . tramp-sh-handle-file-acl) @@ -1021,7 +1024,6 @@ of command line.") (file-truename . tramp-sh-handle-file-truename) (file-writable-p . tramp-sh-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) - ;; `find-file-noselect' performed by default handler. ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-sh-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) @@ -1096,8 +1098,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 @@ -1124,7 +1126,7 @@ component is used as the target of the symlink." 'file-name-as-directory 'identity) (with-parsed-tramp-file-name (expand-file-name filename) nil (tramp-make-tramp-file-name - method user domain host port + v (with-tramp-file-property v localname "file-truename" (let ((result nil) ; result steps in reverse order (quoted (tramp-compat-file-name-quoted-p localname)) @@ -1176,12 +1178,13 @@ component is used as the target of the symlink." (tramp-compat-file-attribute-type (file-attributes (tramp-make-tramp-file-name - method user domain host port + v (mapconcat 'identity (append '("") (reverse result) (list thisstep)) - "/"))))) + "/") + 'nohop)))) (cond ((string= "." thisstep) (tramp-message v 5 "Ignoring step `.'")) ((string= ".." thisstep) @@ -1225,7 +1228,8 @@ component is used as the target of the symlink." (let (file-name-handler-alist) (setq result (tramp-compat-file-name-quote result)))) (tramp-message v 4 "True name of `%s' is `%s'" localname result) - result)))))) + result)) + 'nohop)))) ;; Basic functions. @@ -1253,18 +1257,24 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname (format "file-attributes-%s" id-format) - (save-excursion - (tramp-convert-file-attributes - v - (or - (cond - ((tramp-get-remote-stat v) - (tramp-do-file-attributes-with-stat v localname id-format)) - ((tramp-get-remote-perl v) - (tramp-do-file-attributes-with-perl v localname id-format)) - (t nil)) - ;; The scripts could fail, for example with huge file size. - (tramp-do-file-attributes-with-ls v localname id-format))))))))) + (tramp-convert-file-attributes + v + (or + (cond + ((tramp-get-remote-stat v) + (tramp-do-file-attributes-with-stat v localname id-format)) + ((tramp-get-remote-perl v) + (tramp-do-file-attributes-with-perl v localname id-format)) + (t nil)) + ;; The scripts could fail, for example with huge file size. + (tramp-do-file-attributes-with-ls v localname id-format)))))))) + +(defun tramp-sh--quoting-style-options (vec) + (or + (tramp-get-ls-command-with + vec "--quoting-style=literal --show-control-chars") + (tramp-get-ls-command-with vec "-w") + "")) (defun tramp-do-file-attributes-with-ls (vec localname &optional id-format) "Implement `file-attributes' for Tramp files using the ls(1) command." @@ -1291,12 +1301,7 @@ component is used as the target of the symlink." (if (eq id-format 'integer) "-ildn" "-ild") ;; On systems which have no quoting style, file names ;; with special characters could fail. - (cond - ((tramp-get-ls-command-with-quoting-style vec) - "--quoting-style=c") - ((tramp-get-ls-command-with-w-option vec) - "-w") - (t "")) + (tramp-sh--quoting-style-options vec) (tramp-shell-quote-argument localname))) ;; Parse `ls -l' output ... (with-current-buffer (tramp-get-buffer vec) @@ -1329,7 +1334,7 @@ component is used as the target of the symlink." (when symlinkp (search-forward "-> ") (setq res-symlink-target - (if (tramp-get-ls-command-with-quoting-style vec) + (if (looking-at-p "\"") (read (current-buffer)) (buffer-substring (point) (point-at-eol))))) ;; Return data gathered. @@ -1343,13 +1348,10 @@ component is used as the target of the symlink." res-uid ;; 3. File gid. res-gid - ;; 4. Last access time, as a list of integers. Normally - ;; this would be in the same format as `current-time', but - ;; the subseconds part is not currently implemented, and - ;; (0 0) denotes an unknown time. - ;; 5. Last modification time, likewise. - ;; 6. Last status change time, likewise. - '(0 0) '(0 0) '(0 0) ;CCC how to find out? + ;; 4. Last access time. + ;; 5. Last modification time. + ;; 6. Last status change time. + tramp-time-dont-know tramp-time-dont-know tramp-time-dont-know ;; 7. Size in bytes (-1, if number is out of range). res-size ;; 8. File modes, as a string of ten letters or dashes as in ls -l. @@ -1380,15 +1382,16 @@ component is used as the target of the symlink." (tramp-send-command-and-read vec (format - (concat - ;; On Opsware, pdksh (which is the true name of ksh there) - ;; doesn't parse correctly the sequence "((". Therefore, we add - ;; a space. Apostrophes in the stat output are masked as - ;; `tramp-stat-marker', in order to make a proper shell escape of - ;; them in file names. - "( (%s %s || %s -h %s) && (%s -c " - "'((%s%%N%s) %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 %s%%A%s t %%ie0 -1)' " - "%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g') || echo nil)") + (eval-when-compile + (concat + ;; On Opsware, pdksh (which is the true name of ksh there) + ;; doesn't parse correctly the sequence "((". Therefore, we + ;; add a space. Apostrophes in the stat output are masked as + ;; `tramp-stat-marker', in order to make a proper shell escape + ;; of them in file names. + "( (%s %s || %s -h %s) && (%s -c " + "'((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " + "%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g') || echo nil)")) (tramp-get-file-exists-command vec) (tramp-shell-quote-argument localname) (tramp-get-test-command vec) @@ -1396,9 +1399,11 @@ component is used as the target of the symlink." (tramp-get-remote-stat vec) tramp-stat-marker tramp-stat-marker (if (eq id-format 'integer) - "%ue0" (concat tramp-stat-marker "%U" tramp-stat-marker)) + "%u" + (eval-when-compile (concat tramp-stat-marker "%U" tramp-stat-marker))) (if (eq id-format 'integer) - "%ge0" (concat tramp-stat-marker "%G" tramp-stat-marker)) + "%g" + (eval-when-compile (concat tramp-stat-marker "%G" tramp-stat-marker))) tramp-stat-marker tramp-stat-marker (tramp-shell-quote-argument localname) tramp-stat-quoted-marker))) @@ -1415,13 +1420,10 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name f nil (let* ((remote-file-name-inhibit-cache t) (attr (file-attributes f)) - ;; '(-1 65535) means file doesn't exists yet. (modtime (or (tramp-compat-file-attribute-modification-time attr) - '(-1 65535)))) + tramp-time-doesnt-exist))) (setq coding-system-used last-coding-system-used) - ;; We use '(0 0) as a don't-know value. See also - ;; `tramp-do-file-attributes-with-ls'. - (if (not (equal modtime '(0 0))) + (if (not (tramp-compat-time-equal-p modtime tramp-time-dont-know)) (tramp-run-real-handler 'set-visited-file-modtime (list modtime)) (progn (tramp-send-command @@ -1450,7 +1452,7 @@ of." ;; recorded last modification time, or there is no established ;; connection. (if (or (not f) - (eq (visited-file-modtime) 0) + (zerop (float-time (visited-file-modtime))) (not (file-remote-p f nil 'connected))) t (with-parsed-tramp-file-name f nil @@ -1461,16 +1463,10 @@ of." (cond ;; File exists, and has a known modtime. - ((and attr (not (equal modtime '(0 0)))) - (< (abs (tramp-time-diff - modtime - ;; For compatibility, deal with both the old - ;; (HIGH . LOW) and the new (HIGH LOW) return - ;; values of `visited-file-modtime'. - (if (atom (cdr mt)) - (list (car mt) (cdr mt)) - mt))) - 2)) + ((and attr + (not + (tramp-compat-time-equal-p modtime tramp-time-dont-know))) + (< (abs (tramp-time-diff modtime mt)) 2)) ;; Modtime has the don't know value. (attr (tramp-send-command @@ -1486,13 +1482,13 @@ of." v localname "visited-file-modtime-ild" ""))) ;; If file does not exist, say it is not modified if and ;; only if that agrees with the buffer's record. - (t (equal mt '(-1 65535)))))))))) + (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist))))))))) (defun tramp-sh-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) ;; FIXME: extract the proper text from chmod's stderr. (tramp-barf-unless-okay v @@ -1503,11 +1499,14 @@ of." "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (when (tramp-get-remote-touch v) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) - (let ((time (if (or (null time) (equal time '(0 0))) - (current-time) - time))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (let ((time + (if (or (null time) + (tramp-compat-time-equal-p time tramp-time-doesnt-exist) + (tramp-compat-time-equal-p time tramp-time-dont-know)) + (current-time) + time))) (tramp-send-command-and-check v (format "env TZ=UTC %s %s %s" @@ -1561,8 +1560,9 @@ be non-negative integers." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-selinux-context" (let ((context '(nil nil nil nil)) - (regexp (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):" - "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)"))) + (regexp (eval-when-compile + (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):" + "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)")))) (when (and (tramp-remote-selinux-p v) (tramp-send-command-and-check v (format @@ -1596,8 +1596,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) @@ -1637,7 +1636,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. @@ -1667,25 +1666,23 @@ be non-negative integers." ;; something smarter about it. (defun tramp-sh-handle-file-newer-than-file-p (file1 file2) "Like `file-newer-than-file-p' for Tramp files." - (cond ((not (file-exists-p file1)) - nil) - ((not (file-exists-p file2)) - t) - ;; We are sure both files exist at this point. - (t - (save-excursion - ;; We try to get the mtime of both files. If they are not - ;; equal to the "dont-know" value, then we subtract the times - ;; and obtain the result. + (cond ((not (file-exists-p file1)) nil) + ((not (file-exists-p file2)) t) + (t ;; We are sure both files exist at this point. We try to + ;; get the mtime of both files. If they are not equal to + ;; the "dont-know" value, then we subtract the times and + ;; obtain the result. (let ((fa1 (file-attributes file1)) (fa2 (file-attributes file2))) (if (and (not - (equal (tramp-compat-file-attribute-modification-time fa1) - '(0 0))) + (tramp-compat-time-equal-p + (tramp-compat-file-attribute-modification-time fa1) + tramp-time-dont-know)) (not - (equal (tramp-compat-file-attribute-modification-time fa2) - '(0 0)))) + (tramp-compat-time-equal-p + (tramp-compat-file-attribute-modification-time fa2) + tramp-time-dont-know))) (> 0 (tramp-time-diff (tramp-compat-file-attribute-modification-time fa2) (tramp-compat-file-attribute-modification-time fa1))) @@ -1703,7 +1700,7 @@ be non-negative integers." file1 file2))) (with-parsed-tramp-file-name file1 nil (tramp-run-test2 - (tramp-get-test-nt-command v) file1 file2)))))))) + (tramp-get-test-nt-command v) file1 file2))))))) ;; Functions implemented using the basic functions above. @@ -1760,25 +1757,22 @@ be non-negative integers." (with-tramp-file-property v localname (format "directory-files-and-attributes-%s" id-format) - (save-excursion - (mapcar - (lambda (x) - (cons (car x) - (tramp-convert-file-attributes v (cdr x)))) - (or - (cond - ((tramp-get-remote-stat v) - (tramp-do-directory-files-and-attributes-with-stat - v localname id-format)) - ((tramp-get-remote-perl v) - (tramp-do-directory-files-and-attributes-with-perl - v localname id-format)) - (t nil))))))))) + (mapcar + (lambda (x) + (cons (car x) (tramp-convert-file-attributes v (cdr x)))) + (cond + ((tramp-get-remote-stat v) + (tramp-do-directory-files-and-attributes-with-stat + v localname id-format)) + ((tramp-get-remote-perl v) + (tramp-do-directory-files-and-attributes-with-perl + v localname id-format)) + (t nil))))))) result item) (while temp (setq item (pop temp)) - (when (or (null match) (string-match match (car item))) + (when (or (null match) (string-match-p match (car item))) (when full (setcar item (expand-file-name (car item) directory))) (push item result))) @@ -1812,33 +1806,32 @@ be non-negative integers." (tramp-send-command-and-read vec (format - (concat - ;; We must care about file names with spaces, or starting with - ;; "-"; this would confuse xargs. "ls -aQ" might be a solution, - ;; but it does not work on all remote systems. Apostrophes in - ;; the stat output are masked as `tramp-stat-marker', in order to - ;; make a proper shell escape of them in file names. - "cd %s && echo \"(\"; (%s %s -a | " - "xargs %s -c " - "'(%s%%n%s (%s%%N%s) %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 %s%%A%s t %%ie0 -1)' " - "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"") + (eval-when-compile + (concat + ;; We must care about file names with spaces, or starting with + ;; "-"; this would confuse xargs. "ls -aQ" might be a + ;; solution, but it does not work on all remote systems. + ;; Apostrophes in the stat output are masked as + ;; `tramp-stat-marker', in order to make a proper shell escape + ;; of them in file names. + "cd %s && echo \"(\"; (%s %s -a | " + "xargs %s -c " + "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " + "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"")) (tramp-shell-quote-argument localname) (tramp-get-ls-command vec) ;; On systems which have no quoting style, file names with special ;; characters could fail. - (cond - ((tramp-get-ls-command-with-quoting-style vec) - "--quoting-style=shell") - ((tramp-get-ls-command-with-w-option vec) - "-w") - (t "")) + (tramp-sh--quoting-style-options vec) (tramp-get-remote-stat vec) tramp-stat-marker tramp-stat-marker tramp-stat-marker tramp-stat-marker (if (eq id-format 'integer) - "%ue0" (concat tramp-stat-marker "%U" tramp-stat-marker)) + "%u" + (eval-when-compile (concat tramp-stat-marker "%U" tramp-stat-marker))) (if (eq id-format 'integer) - "%ge0" (concat tramp-stat-marker "%G" tramp-stat-marker)) + "%g" + (eval-when-compile (concat tramp-stat-marker "%G" tramp-stat-marker))) tramp-stat-marker tramp-stat-marker tramp-stat-quoted-marker))) @@ -1846,7 +1839,7 @@ be non-negative integers." ;; files. (defun tramp-sh-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (unless (save-match-data (string-match "/" filename)) + (unless (string-match-p "/" filename) (all-completions filename (with-parsed-tramp-file-name (expand-file-name directory) nil @@ -1865,12 +1858,13 @@ be non-negative integers." (format "tramp_perl_file_name_all_completions %s" (tramp-shell-quote-argument localname))) - (format (concat - "(cd %s 2>&1 && %s -a 2>/dev/null" - " | while IFS= read f; do" - " if %s -d \"$f\" 2>/dev/null;" - " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done" - " && \\echo ok) || \\echo fail") + (format (eval-when-compile + (concat + "(cd %s 2>&1 && %s -a 2>/dev/null" + " | while IFS= read f; do" + " if %s -d \"$f\" 2>/dev/null;" + " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done" + " && \\echo ok) || \\echo fail")) (tramp-shell-quote-argument localname) (tramp-get-ls-command v) (tramp-get-test-command v)))) @@ -1881,7 +1875,7 @@ be non-negative integers." ;; Check result code, found in last line of output. (forward-line -1) - (if (looking-at "^fail$") + (if (looking-at-p "^fail$") (progn ;; Grab error message from line before last line ;; (it was put there by `cd 2>&1'). @@ -1894,7 +1888,7 @@ be non-negative integers." ;; then it should end in `ok'. If neither are in the ;; buffer something went seriously wrong on the remote ;; side. - (unless (looking-at "^ok$") + (unless (looking-at-p "^ok$") (tramp-error v 'file-error "\ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" @@ -1931,8 +1925,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 @@ -1998,8 +1992,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) @@ -2048,6 +2042,7 @@ file names." (t2 (tramp-tramp-file-p newname)) (length (tramp-compat-file-attribute-size (file-attributes (file-truename filename)))) + ;; `file-extended-attributes' exists since Emacs 24.4. (attributes (and preserve-extended-attributes (apply 'file-extended-attributes (list filename))))) @@ -2126,14 +2121,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. @@ -2195,8 +2192,8 @@ the uid and gid from FILENAME." v 'file-error "Unknown operation `%s', must be `copy' or `rename'" op)))) - (localname1 (if t1 (file-remote-p filename 'localname) filename)) - (localname2 (if t2 (file-remote-p newname 'localname) newname)) + (localname1 (tramp-compat-file-local-name filename)) + (localname2 (tramp-compat-file-local-name newname)) (prefix (file-remote-p (if t1 filename newname))) cmd-result) (when (and (eq op 'copy) (file-directory-p filename)) @@ -2357,15 +2354,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) @@ -2510,7 +2498,7 @@ The method used must be an out-of-band method." (tramp-get-connection-buffer v) command)))) (tramp-message orig-vec 6 "%s" command) - (tramp-set-connection-property p "vector" orig-vec) + (process-put p 'vector orig-vec) (process-put p 'adjust-window-size-function 'ignore) (set-process-query-on-exit-flag p nil) @@ -2521,8 +2509,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))) @@ -2553,20 +2541,23 @@ The method used must be an out-of-band method." "Like `make-directory' for Tramp files." (setq dir (expand-file-name dir)) (with-parsed-tramp-file-name dir nil - (tramp-flush-directory-property v (file-name-directory localname)) - (save-excursion - (tramp-barf-unless-okay - v (format "%s %s" - (if parents "mkdir -p" "mkdir") - (tramp-shell-quote-argument localname)) - "Couldn't make directory %s" dir)))) + ;; When PARENTS is non-nil, DIR could be a chain of non-existent + ;; directories a/b/c/... Instead of checking, we simply flush the + ;; whole cache. + (tramp-flush-directory-properties + v (if parents "/" (file-name-directory localname))) + (tramp-barf-unless-okay + v (format "%s %s" + (if parents "mkdir -p" "mkdir") + (tramp-shell-quote-argument localname)) + "Couldn't make directory %s" dir))) (defun tramp-sh-handle-delete-directory (directory &optional recursive trash) "Like `delete-directory' for Tramp files." (setq directory (expand-file-name directory)) (with-parsed-tramp-file-name directory nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (tramp-barf-unless-okay v (format "cd / && %s %s" (or (and trash (tramp-get-remote-trash v)) @@ -2578,8 +2569,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") @@ -2592,42 +2583,40 @@ The method used must be an out-of-band method." "Like `dired-compress-file' for Tramp files." ;; Code stolen mainly from dired-aux.el. (with-parsed-tramp-file-name file nil - (tramp-flush-file-property v localname) - (save-excursion - (let ((suffixes dired-compress-file-suffixes) - suffix) - ;; See if any suffix rule matches this file name. - (while suffixes - (let (case-fold-search) - (if (string-match (car (car suffixes)) localname) - (setq suffix (car suffixes) suffixes nil)) - (setq suffixes (cdr suffixes)))) - - (cond ((file-symlink-p file) - nil) - ((and suffix (nth 2 suffix)) - ;; We found an uncompression rule. - (with-tramp-progress-reporter - v 0 (format "Uncompressing %s" file) - (when (tramp-send-command-and-check - v (concat (nth 2 suffix) " " - (tramp-shell-quote-argument localname))) - (dired-remove-file file) - (string-match (car suffix) file) - (concat (substring file 0 (match-beginning 0)))))) - (t - ;; We don't recognize the file as compressed, so compress it. - ;; Try gzip. - (with-tramp-progress-reporter v 0 (format "Compressing %s" file) - (when (tramp-send-command-and-check - v (concat "gzip -f " - (tramp-shell-quote-argument localname))) - (dired-remove-file file) - (cond ((file-exists-p (concat file ".gz")) - (concat file ".gz")) - ((file-exists-p (concat file ".z")) - (concat file ".z")) - (t nil)))))))))) + (tramp-flush-file-properties v localname) + (let ((suffixes dired-compress-file-suffixes) + suffix) + ;; See if any suffix rule matches this file name. + (while suffixes + (let (case-fold-search) + (if (string-match-p (car (car suffixes)) localname) + (setq suffix (car suffixes) suffixes nil)) + (setq suffixes (cdr suffixes)))) + + (cond ((file-symlink-p file) nil) + ((and suffix (nth 2 suffix)) + ;; We found an uncompression rule. + (with-tramp-progress-reporter + v 0 (format "Uncompressing %s" file) + (when (tramp-send-command-and-check + v (concat (nth 2 suffix) " " + (tramp-shell-quote-argument localname))) + (dired-remove-file file) + (string-match (car suffix) file) + (concat (substring file 0 (match-beginning 0)))))) + (t + ;; We don't recognize the file as compressed, so compress it. + ;; Try gzip. + (with-tramp-progress-reporter v 0 (format "Compressing %s" file) + (when (tramp-send-command-and-check + v (concat "gzip -f " + (tramp-shell-quote-argument localname))) + (dired-remove-file file) + (cond ((file-exists-p (concat file ".gz")) + (concat file ".gz")) + ((file-exists-p (concat file ".z")) + (concat file ".z")) + (t nil))))))))) (defun tramp-sh-handle-insert-directory (filename switches &optional wildcard full-directory-p) @@ -2641,10 +2630,12 @@ The method used must be an out-of-band method." filename switches wildcard full-directory-p) (when (stringp switches) (setq switches (split-string switches))) - (when (tramp-get-ls-command-with-quoting-style v) - (setq switches (append switches '("--quoting-style=literal")))) - (when (and (member "--dired" switches) - (not (tramp-get-ls-command-with-dired v))) + (when (tramp-get-ls-command-with ;FIXME: tramp-sh--quoting-style-options? + v "--quoting-style=literal --show-control-chars") + (setq switches + (append + switches '("--quoting-style=literal" "--show-control-chars")))) + (unless (tramp-get-ls-command-with v "--dired") (setq switches (delete "--dired" switches))) (when wildcard (setq wildcard (tramp-run-real-handler @@ -2705,7 +2696,7 @@ The method used must be an out-of-band method." ;; Check for "--dired" output. (forward-line -2) - (when (looking-at "//SUBDIRED//") + (when (looking-at-p "//SUBDIRED//") (forward-line -1)) (when (looking-at "//DIRED//\\s-+") (let ((databeg (match-end 0)) @@ -2726,7 +2717,7 @@ The method used must be an out-of-band method." ;; Some busyboxes are reluctant to discard colors. (unless - (string-match "color" (tramp-get-connection-property v "ls" "")) + (string-match-p "color" (tramp-get-connection-property v "ls" "")) (goto-char beg) (while (re-search-forward tramp-display-escape-sequence-regexp nil t) @@ -2794,7 +2785,7 @@ the result will be a local, non-Tramp, file name." ;; appropriate either, because ssh and companions might ;; use a user name from the config file. (when (and (string-equal uname "~") - (string-match "\\`su\\(do\\)?\\'" method)) + (string-match-p "\\`su\\(do\\)?\\'" method)) (setq uname (concat uname user))) (setq uname (with-tramp-connection-property v uname @@ -2814,22 +2805,20 @@ the result will be a local, non-Tramp, file name." ;; be problems with UNC shares or Cygwin mounts. (let ((default-directory (tramp-compat-temporary-file-directory))) (tramp-make-tramp-file-name - method user domain host port - (tramp-drop-volume-letter - (tramp-run-real-handler - 'expand-file-name (list localname))) - hop))))) + v (tramp-drop-volume-letter + (tramp-run-real-handler + 'expand-file-name (list localname)))))))) ;;; Remote commands: (defun tramp-process-sentinel (proc event) "Flush file caches." (unless (process-live-p proc) - (let ((vec (tramp-get-connection-property proc "vector" nil))) + (let ((vec (process-get proc 'vector))) (when vec (tramp-message vec 5 "Sentinel called: `%S' `%s'" proc event) - (tramp-flush-connection-property proc) - (tramp-flush-directory-property vec ""))))) + (tramp-flush-connection-properties proc) + (tramp-flush-directory-properties vec ""))))) ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once @@ -2846,7 +2835,7 @@ the result will be a local, non-Tramp, file name." ;; it might be that the arguments exceed the command line ;; length. Therefore, we modify the command. (heredoc (and (stringp program) - (string-match "sh$" program) + (string-match-p "sh$" program) (string-equal "-c" (car args)) (= (length args) 2))) ;; When PROGRAM is nil, we just provide a tty. @@ -2863,20 +2852,14 @@ 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'. env uenv (env (dolist (elt (cons prompt process-environment) env) (or (member elt (default-toplevel-value 'process-environment)) - (if (string-match "=" elt) + (if (string-match-p "=" elt) (setq env (append env `(,elt))) (if (tramp-get-env-with-u-option v) (setq env (append `("-u" ,elt) env)) @@ -2966,13 +2949,13 @@ the result will be a local, non-Tramp, file name." p))) ;; Save exit. - (if (string-match tramp-temp-buffer-name (buffer-name)) + (if (string-match-p tramp-temp-buffer-name (buffer-name)) (ignore-errors (set-process-buffer p nil) (kill-buffer (current-buffer))) (set-buffer-modified-p bmp)) - (tramp-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) @@ -2989,7 +2972,7 @@ the result will be a local, non-Tramp, file name." ;; We use as environment the difference to toplevel `process-environment'. (dolist (elt process-environment) (or (member elt (default-toplevel-value 'process-environment)) - (if (string-match "=" elt) + (if (string-match-p "=" elt) (setq env (append env `(,elt))) (if (tramp-get-env-with-u-option v) (setq env (append `("-u" ,elt) env)) @@ -3013,8 +2996,7 @@ the result will be a local, non-Tramp, file name." (setq input (with-parsed-tramp-file-name infile nil localname)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) - tmpinput - (tramp-make-tramp-file-name method user domain host port input)) + tmpinput (tramp-make-tramp-file-name v input 'nohop)) (copy-file infile tmpinput t))) (when input (setq command (format "%s <%s" command input))) @@ -3047,8 +3029,7 @@ the result will be a local, non-Tramp, file name." ;; stderr must be copied to remote host. The temporary ;; file must be deleted after execution. (setq stderr (tramp-make-tramp-temp-file v) - tmpstderr (tramp-make-tramp-file-name - method user domain host port stderr)))) + tmpstderr (tramp-make-tramp-file-name v stderr 'nohop)))) ;; stderr to be discarded. ((null (cadr destination)) (setq stderr "/dev/null")))) @@ -3094,13 +3075,20 @@ the result will be a local, non-Tramp, file name." (when tmpinput (delete-file tmpinput)) (unless process-file-side-effects - (tramp-flush-directory-property v "")) + (tramp-flush-directory-properties v "")) ;; Return exit status. (if (equal ret -1) (keyboard-quit) ret)))) +(defun tramp-sh-handle-exec-path () + "Like `exec-path' for Tramp files." + (append + (tramp-get-remote-path (tramp-dissect-file-name default-directory)) + ;; The equivalent to `exec-directory'. + `(,(tramp-compat-file-local-name default-directory)))) + (defun tramp-sh-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil @@ -3124,50 +3112,49 @@ the result will be a local, non-Tramp, file name." ;; Use inline encoding for file transfer. (rem-enc - (save-excursion - (with-tramp-progress-reporter - v 3 - (format-message "Encoding remote file `%s' with `%s'" - filename rem-enc) - (tramp-barf-unless-okay - v (format rem-enc (tramp-shell-quote-argument localname)) - "Encoding remote file failed")) - - (with-tramp-progress-reporter - v 3 (format-message "Decoding local file `%s' with `%s'" - tmpfile loc-dec) - (if (functionp loc-dec) - ;; If local decoding is a function, we call it. - ;; We must disable multibyte, because - ;; `uudecode-decode-region' doesn't handle it - ;; correctly. Unset `file-name-handler-alist'. - ;; Otherwise, epa-file gets confused. - (let (file-name-handler-alist - (coding-system-for-write 'binary)) - (with-temp-file tmpfile - (set-buffer-multibyte nil) - (insert-buffer-substring (tramp-get-buffer v)) - (funcall loc-dec (point-min) (point-max)))) - - ;; If tramp-decoding-function is not defined for this - ;; method, we invoke tramp-decoding-command instead. - (let ((tmpfile2 (tramp-compat-make-temp-file filename))) - ;; Unset `file-name-handler-alist'. Otherwise, - ;; epa-file gets confused. - (let (file-name-handler-alist - (coding-system-for-write 'binary)) - (with-current-buffer (tramp-get-buffer v) - (write-region - (point-min) (point-max) tmpfile2 nil 'no-message))) - (unwind-protect - (tramp-call-local-coding-command - loc-dec tmpfile2 tmpfile) - (delete-file tmpfile2))))) - - ;; Set proper permissions. - (set-file-modes tmpfile (tramp-default-file-modes filename)) - ;; Set local user ownership. - (tramp-set-file-uid-gid tmpfile))) + (with-tramp-progress-reporter + v 3 + (format-message + "Encoding remote file `%s' with `%s'" filename rem-enc) + (tramp-barf-unless-okay + v (format rem-enc (tramp-shell-quote-argument localname)) + "Encoding remote file failed")) + + (with-tramp-progress-reporter + v 3 (format-message + "Decoding local file `%s' with `%s'" tmpfile loc-dec) + (if (functionp loc-dec) + ;; If local decoding is a function, we call it. We + ;; must disable multibyte, because + ;; `uudecode-decode-region' doesn't handle it + ;; correctly. Unset `file-name-handler-alist'. + ;; Otherwise, epa-file gets confused. + (let (file-name-handler-alist + (coding-system-for-write 'binary)) + (with-temp-file tmpfile + (set-buffer-multibyte nil) + (insert-buffer-substring (tramp-get-buffer v)) + (funcall loc-dec (point-min) (point-max)))) + + ;; If tramp-decoding-function is not defined for this + ;; method, we invoke tramp-decoding-command instead. + (let ((tmpfile2 (tramp-compat-make-temp-file filename))) + ;; Unset `file-name-handler-alist'. Otherwise, + ;; epa-file gets confused. + (let (file-name-handler-alist + (coding-system-for-write 'binary)) + (with-current-buffer (tramp-get-buffer v) + (write-region + (point-min) (point-max) tmpfile2 nil 'no-message))) + (unwind-protect + (tramp-call-local-coding-command + loc-dec tmpfile2 tmpfile) + (delete-file tmpfile2))))) + + ;; Set proper permissions. + (set-file-modes tmpfile (tramp-default-file-modes filename)) + ;; Set local user ownership. + (tramp-set-file-uid-gid tmpfile)) ;; Oops, I don't know what to do. (t (tramp-error @@ -3333,8 +3320,9 @@ the result will be a local, non-Tramp, file name." loc-enc tmpfile t)) (tramp-error v 'file-error - (concat "Cannot write to `%s', " - "local encoding command `%s' failed") + (eval-when-compile + (concat "Cannot write to `%s', " + "local encoding command `%s' failed")) filename loc-enc)))) ;; Send buffer into remote decoding command which @@ -3379,8 +3367,9 @@ the result will be a local, non-Tramp, file name." (buffer-string)))) (tramp-error v 'file-error - (concat "Couldn't write region to `%s'," - " decode using `%s' failed") + (eval-when-compile + (concat "Couldn't write region to `%s'," + " decode using `%s' failed")) filename rem-dec))))) ;; Save exit. @@ -3390,16 +3379,17 @@ the result will be a local, non-Tramp, file name." (t (tramp-error v 'file-error - (concat "Method `%s' should specify both encoding and " - "decoding command or an scp program") + (eval-when-compile + (concat "Method `%s' should specify both encoding and " + "decoding command or an scp program")) method)))) ;; Make `last-coding-system-used' have the right value. (when coding-system-used (set 'last-coding-system-used coding-system-used)))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) ;; We must protect `last-coding-system-used', now we have set it ;; to its correct value. @@ -3572,29 +3562,19 @@ Fall back to normal file name handler if no Tramp handler exists." (let ((default-directory (file-name-directory file-name)) command events filter p sequence) (cond - ;; gvfs-monitor-dir. - ((setq command (tramp-get-remote-gvfs-monitor-dir v)) - (setq filter 'tramp-sh-gvfs-monitor-dir-process-filter - events - (cond - ((and (memq 'change flags) (memq 'attribute-change flags)) - '(created changed changes-done-hint moved deleted - attribute-changed)) - ((memq 'change flags) - '(created changed changes-done-hint moved deleted)) - ((memq 'attribute-change flags) '(attribute-changed))) - sequence `(,command ,localname))) - ;; inotifywait. + ;; "inotifywait". ((setq command (tramp-get-remote-inotifywait v)) (setq filter 'tramp-sh-inotifywait-process-filter events (cond ((and (memq 'change flags) (memq 'attribute-change flags)) - (concat "create,modify,move,moved_from,moved_to,move_self," - "delete,delete_self,attrib,ignored")) + (eval-when-compile + (concat "create,modify,move,moved_from,moved_to,move_self," + "delete,delete_self,attrib,ignored"))) ((memq 'change flags) - (concat "create,modify,move,moved_from,moved_to,move_self," - "delete,delete_self,ignored")) + (eval-when-compile + (concat "create,modify,move,moved_from,moved_to,move_self," + "delete,delete_self,ignored"))) ((memq 'attribute-change flags) "attrib,ignored")) sequence `(,command "-mq" "-e" ,events ,localname) ;; Make events a list of symbols. @@ -3602,6 +3582,30 @@ Fall back to normal file name handler if no Tramp handler exists." (mapcar (lambda (x) (intern-soft (replace-regexp-in-string "_" "-" x))) (split-string events "," 'omit)))) + ;; "gio monitor". + ((setq command (tramp-get-remote-gio-monitor v)) + (setq filter 'tramp-sh-gio-monitor-process-filter + events + (cond + ((and (memq 'change flags) (memq 'attribute-change flags)) + '(created changed changes-done-hint moved deleted + attribute-changed)) + ((memq 'change flags) + '(created changed changes-done-hint moved deleted)) + ((memq 'attribute-change flags) '(attribute-changed))) + sequence `(,command "monitor" ,localname))) + ;; "gvfs-monitor-dir". + ((setq command (tramp-get-remote-gvfs-monitor-dir v)) + (setq filter 'tramp-sh-gvfs-monitor-dir-process-filter + events + (cond + ((and (memq 'change flags) (memq 'attribute-change flags)) + '(created changed changes-done-hint moved deleted + attribute-changed)) + ((memq 'change flags) + '(created changed changes-done-hint moved deleted)) + ((memq 'attribute-change flags) '(attribute-changed))) + sequence `(,command ,localname))) ;; None. (t (tramp-error v 'file-notify-error @@ -3621,7 +3625,7 @@ Fall back to normal file name handler if no Tramp handler exists." "`%s' failed to start on remote host" (mapconcat 'identity sequence " ")) (tramp-message v 6 "Run `%s', %S" (mapconcat 'identity sequence " ") p) - (tramp-set-connection-property p "vector" v) + (process-put p 'vector v) ;; Needed for process filter. (process-put p 'events events) (process-put p 'watch-name localname) @@ -3632,9 +3636,69 @@ Fall back to normal file name handler if no Tramp handler exists." (tramp-accept-process-output p 1) (unless (process-live-p p) (tramp-error - v 'file-notify-error "Monitoring not supported for `%s'" file-name)) + p 'file-notify-error "Monitoring not supported for `%s'" file-name)) p)))) +(defun tramp-sh-gio-monitor-process-filter (proc string) + "Read output from \"gio monitor\" and add corresponding file-notify events." + (let ((events (process-get proc 'events)) + (remote-prefix + (with-current-buffer (process-buffer proc) + (file-remote-p default-directory))) + (rest-string (process-get proc 'rest-string))) + (when rest-string + (tramp-message proc 10 "Previous string:\n%s" rest-string)) + (tramp-message proc 6 "%S\n%s" proc string) + (setq string (concat rest-string string) + ;; Fix action names. + string (replace-regexp-in-string + "attributes changed" "attribute-changed" string) + string (replace-regexp-in-string + "changes done" "changes-done-hint" string) + string (replace-regexp-in-string + "renamed to" "moved" string)) + ;; https://bugs.launchpad.net/bugs/1742946 + (when + (string-match-p "Monitoring not supported\\|No locations given" string) + (delete-process proc)) + + (while (string-match + (eval-when-compile + (concat "^[^:]+:" + "[[:space:]]\\([^:]+\\):" + "[[:space:]]" (regexp-opt tramp-gio-events t) + "\\([[:space:]]\\([^:]+\\)\\)?$")) + string) + + (let* ((file (match-string 1 string)) + (file1 (match-string 4 string)) + (object + (list + proc + (list + (intern-soft (match-string 2 string))) + ;; File names are returned as absolute paths. We must + ;; add the remote prefix. + (concat remote-prefix file) + (when file1 (concat remote-prefix file1))))) + (setq string (replace-match "" nil nil string)) + ;; Remove watch when file or directory to be watched is deleted. + (when (and (member (cl-caadr object) '(moved deleted)) + (string-equal file (process-get proc 'watch-name))) + (delete-process proc)) + ;; Usually, we would add an Emacs event now. Unfortunately, + ;; `unread-command-events' does not accept several events at + ;; once. Therefore, we apply the handler directly. + (when (member (cl-caadr object) events) + (tramp-compat-funcall + 'file-notify-handle-event + `(file-notify ,object file-notify-callback))))) + + ;; Save rest of the string. + (when (zerop (length string)) (setq string nil)) + (when string (tramp-message proc 10 "Rest string:\n%s" string)) + (process-put proc 'rest-string string))) + (defun tramp-sh-gvfs-monitor-dir-process-filter (proc string) "Read output from \"gvfs-monitor-dir\" and add corresponding \ file-notify events." @@ -3650,15 +3714,14 @@ file-notify events." ;; Attribute change is returned in unused wording. string (replace-regexp-in-string "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string)) - (when (string-match "Monitoring not supported" string) - (delete-process proc)) (while (string-match - (concat "^[\n\r]*" - "Directory Monitor Event:[\n\r]+" - "Child = \\([^\n\r]+\\)[\n\r]+" - "\\(Other = \\([^\n\r]+\\)[\n\r]+\\)?" - "Event = \\([^[:blank:]]+\\)[\n\r]+") + (eval-when-compile + (concat "^[\n\r]*" + "Directory Monitor Event:[\n\r]+" + "Child = \\([^\n\r]+\\)[\n\r]+" + "\\(Other = \\([^\n\r]+\\)[\n\r]+\\)?" + "Event = \\([^[:blank:]]+\\)[\n\r]+")) string) (let* ((file (match-string 1 string)) (file1 (match-string 3 string)) @@ -3697,12 +3760,12 @@ file-notify events." (tramp-message proc 6 "%S\n%s" proc string) (dolist (line (split-string string "[\n\r]+" 'omit)) ;; Check, whether there is a problem. - (unless - (string-match - (concat "^[^[:blank:]]+" - "[[:blank:]]+\\([^[:blank:]]+\\)+" - "\\([[:blank:]]+\\([^\n\r]+\\)\\)?") - line) + (unless (string-match-p + (eval-when-compile + (concat "^[^[:blank:]]+" + "[[:blank:]]+\\([^[:blank:]]+\\)+" + "\\([[:blank:]]+\\([^\n\r]+\\)\\)?")) + line) (tramp-error proc 'file-notify-error "%s" line)) (let ((object @@ -3739,15 +3802,16 @@ file-notify events." (goto-char (point-min)) (forward-line) (when (looking-at - (concat "[[:space:]]*\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)")) - (list (string-to-number (concat (match-string 1) "e0")) + (eval-when-compile + (concat "[[:space:]]*\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)"))) + (list (string-to-number (match-string 1)) ;; The second value is the used size. We need the ;; free size. - (- (string-to-number (concat (match-string 1) "e0")) - (string-to-number (concat (match-string 2) "e0"))) - (string-to-number (concat (match-string 3) "e0"))))))))) + (- (string-to-number (match-string 1)) + (string-to-number (match-string 2))) + (string-to-number (match-string 3))))))))) ;;; Internal Functions: @@ -3766,7 +3830,7 @@ Only send the definition if it has not already been done." (setq script (replace-regexp-in-string (make-string 1 ?\t) (make-string 8 ? ) script)) ;; The script could contain a call of Perl. This is masked with `%s'. - (when (and (string-match "%s" script) + (when (and (string-match-p "%s" script) (not (tramp-get-remote-perl vec))) (tramp-error vec 'file-error "No Perl available on remote host")) (tramp-barf-unless-okay @@ -3827,12 +3891,12 @@ This function expects to be in the right *tramp* buffer." ;; 5.11") have problems with this command, we disable the call ;; therefore. (unless (or ignore-path - (string-match - (regexp-opt '("SunOS 5.10" "SunOS 5.11")) + (string-match-p + (eval-when-compile (regexp-opt '("SunOS 5.10" "SunOS 5.11"))) (tramp-get-connection-property vec "uname" ""))) (tramp-send-command vec (format "which \\%s | wc -w" progname)) (goto-char (point-min)) - (if (looking-at "^\\s-*1$") + (if (looking-at-p "^\\s-*1$") (setq result (concat "\\" progname)))) (unless result (when ignore-tilde @@ -3846,11 +3910,12 @@ This function expects to be in the right *tramp* buffer." (setq dirlist (nreverse newdl)))) (tramp-send-command vec - (format (concat "while read d; " - "do if test -x $d/%s && test -f $d/%s; " - "then echo tramp_executable $d/%s; " - "break; fi; done <<'%s'\n" - "%s\n%s") + (format (eval-when-compile + (concat "while read d; " + "do if test -x $d/%s && test -f $d/%s; " + "then echo tramp_executable $d/%s; " + "break; fi; done <<'%s'\n" + "%s\n%s")) progname progname progname tramp-end-of-heredoc (mapconcat 'identity dirlist "\n") @@ -3939,7 +4004,7 @@ file exists and nonzero exit status otherwise." item extra-args) (while (and alist (null extra-args)) (setq item (pop alist)) - (when (string-match (car item) shell) + (when (string-match-p (car item) shell) (setq extra-args (cdr item)))) ;; It is useful to set the prompt in the following command ;; because some people have a setting for $PS1 which /bin/sh @@ -3960,9 +4025,10 @@ file exists and nonzero exit status otherwise." ;; initial probes to ensure the remote shell is usable.) (tramp-send-command vec (format - (concat - "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " - "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s") + (eval-when-compile + (concat + "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " + "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s")) tramp-terminal-type emacs-version tramp-version ; INSIDE_EMACS (or (getenv-internal "ENV" tramp-remote-process-environment) "") @@ -4000,13 +4066,14 @@ file exists and nonzero exit status otherwise." ;; CCC: "root" does not exist always, see my QNAP TS-459. ;; Which check could we apply instead? (tramp-send-command vec "echo ~root" t) - (if (or (string-match "^~root$" (buffer-string)) + (if (or (string-match-p "^~root$" (buffer-string)) ;; The default shell (ksh93) of OpenSolaris and ;; Solaris is buggy. We've got reports for ;; "SunOS 5.10" and "SunOS 5.11" so far. - (string-match (regexp-opt '("SunOS 5.10" "SunOS 5.11")) - (tramp-get-connection-property - vec "uname" ""))) + (string-match-p + (eval-when-compile + (regexp-opt '("SunOS 5.10" "SunOS 5.11"))) + (tramp-get-connection-property vec "uname" ""))) (or (tramp-find-executable vec "bash" (tramp-get-remote-path vec) t t) @@ -4017,9 +4084,10 @@ file exists and nonzero exit status otherwise." default-shell (tramp-message vec 2 - (concat - "Couldn't find a remote shell which groks tilde " - "expansion, using `%s'") + (eval-when-compile + (concat + "Couldn't find a remote shell which groks tilde " + "expansion, using `%s'")) default-shell))) default-shell))) @@ -4036,7 +4104,7 @@ file exists and nonzero exit status otherwise." "Wait for shell prompt and barf if none appears. Looks at process PROC to see if a shell prompt appears in TIMEOUT seconds. If not, it produces an error message with the given ERROR-ARGS." - (let ((vec (tramp-get-connection-property proc "vector" nil))) + (let ((vec (process-get proc 'vector))) (condition-case nil (tramp-wait-for-regexp proc timeout @@ -4065,7 +4133,7 @@ process to set up. VEC specifies the connection." (tramp-send-command vec "echo foo" t) (with-current-buffer (process-buffer proc) (goto-char (point-min)) - (when (looking-at "echo foo") + (when (looking-at-p "echo foo") (tramp-set-connection-property proc "remote-echo" t) (tramp-message vec 5 "Remote echo still on. Ok.") ;; Make sure backspaces and their echo are enabled and no line @@ -4104,10 +4172,10 @@ process to set up. VEC specifies the connection." ;; Use MULE to select the right EOL convention for communicating ;; with the process. (let ((cs (or (and (memq 'utf-8-hfs (coding-system-list)) - (string-match "^Darwin" uname) + (string-match-p "^Darwin" uname) (cons 'utf-8-hfs 'utf-8-hfs)) (and (memq 'utf-8 (coding-system-list)) - (string-match "utf-?8" (tramp-get-remote-locale vec)) + (string-match-p "utf-?8" (tramp-get-remote-locale vec)) (cons 'utf-8 'utf-8)) (process-coding-system proc) (cons 'undecided 'undecided))) @@ -4117,7 +4185,7 @@ process to set up. VEC specifies the connection." cs-encode (or (cdr cs) 'undecided) cs-encode (coding-system-change-eol-conversion - cs-encode (if (string-match "^Darwin" uname) 'mac 'unix))) + cs-encode (if (string-match-p "^Darwin" uname) 'mac 'unix))) (tramp-send-command vec "(echo foo ; echo bar)" t) (goto-char (point-min)) (when (search-forward "\r" nil t) @@ -4141,7 +4209,7 @@ process to set up. VEC specifies the connection." (t (tramp-message vec 5 "Checking remote host type for `send-process-string' bug") - (if (string-match "^FreeBSD" uname) 500 0)))) + (if (string-match-p "^FreeBSD" uname) 500 0)))) ;; Set remote PATH variable. (tramp-set-remote-path vec) @@ -4164,11 +4232,11 @@ process to set up. VEC specifies the connection." ;; IRIX64 bash expands "!" even when in single quotes. This ;; destroys our shell functions, we must disable it. See ;; <http://stackoverflow.com/questions/3291692/irix-bash-shell-expands-expression-in-single-quotes-yet-shouldnt>. - (when (string-match "^IRIX64" uname) + (when (string-match-p "^IRIX64" uname) (tramp-send-command vec "set +H" t)) ;; Disable tab expansion. - (if (string-match "BSD\\|Darwin" uname) + (if (string-match-p "BSD\\|Darwin" uname) (tramp-send-command vec "stty tabs" t) (tramp-send-command vec "stty tab0" t)) @@ -4315,16 +4383,14 @@ Goes through the list `tramp-local-coding-commands' and vec 5 "Checking local encoding function `%s'" loc-enc) (tramp-message vec 5 "Checking local encoding command `%s' for sanity" loc-enc) - (unless (zerop (tramp-call-local-coding-command - loc-enc nil nil)) + (unless (zerop (tramp-call-local-coding-command loc-enc nil nil)) (throw 'wont-work-local nil))) (if (not (stringp loc-dec)) (tramp-message vec 5 "Checking local decoding function `%s'" loc-dec) (tramp-message vec 5 "Checking local decoding command `%s' for sanity" loc-dec) - (unless (zerop (tramp-call-local-coding-command - loc-dec nil nil)) + (unless (zerop (tramp-call-local-coding-command loc-dec nil nil)) (throw 'wont-work-local nil))) ;; Search for remote coding commands with the same format (while (and remote-commands (not found)) @@ -4342,7 +4408,7 @@ Goes through the list `tramp-local-coding-commands' and (throw 'wont-work-remote nil))) ;; Check if remote perl exists when necessary. (when (and (symbolp rem-enc) - (string-match "perl" (symbol-name rem-enc)) + (string-match-p "perl" (symbol-name rem-enc)) (not (tramp-get-remote-perl vec))) (throw 'wont-work-remote nil)) ;; Check if remote encoding and decoding commands can be @@ -4355,7 +4421,7 @@ Goes through the list `tramp-local-coding-commands' and ;; it might change the permissions of /dev/null! (when (not (stringp rem-enc)) (let ((name (symbol-name rem-enc))) - (while (string-match (regexp-quote "-") name) + (while (string-match "-" name) (setq name (replace-match "_" nil t name))) (tramp-maybe-send-script vec (symbol-value rem-enc) name) (setq rem-enc name))) @@ -4370,9 +4436,9 @@ Goes through the list `tramp-local-coding-commands' and (let ((name (symbol-name rem-dec)) (value (symbol-value rem-dec)) tmpfile) - (while (string-match (regexp-quote "-") name) + (while (string-match "-" name) (setq name (replace-match "_" nil t name))) - (when (string-match "\\(^\\|[^%]\\)%t" value) + (when (string-match-p "\\(^\\|[^%]\\)%t" value) (setq tmpfile (make-temp-name (expand-file-name @@ -4382,8 +4448,7 @@ Goes through the list `tramp-local-coding-commands' and (format-spec value (format-spec-make - ?t - (file-remote-p tmpfile 'localname))))) + ?t (tramp-compat-file-local-name tmpfile))))) (tramp-maybe-send-script vec value name) (setq rem-dec name))) (tramp-message @@ -4397,7 +4462,7 @@ Goes through the list `tramp-local-coding-commands' and (with-current-buffer (tramp-get-buffer vec) (goto-char (point-min)) - (unless (looking-at (regexp-quote magic)) + (unless (looking-at-p (regexp-quote magic)) (throw 'wont-work-remote nil))) ;; `rem-enc' and `rem-dec' could be a string meanwhile. @@ -4427,12 +4492,12 @@ means standard output and thus the current buffer), or nil (which means discard it)." (tramp-call-process nil tramp-encoding-shell - (when (and input (not (string-match "%s" cmd))) input) + (when (and input (not (string-match-p "%s" cmd))) input) (if (eq output t) t nil) nil tramp-encoding-command-switch (concat - (if (string-match "%s" cmd) (format cmd input) cmd) + (if (string-match-p "%s" cmd) (format cmd input) cmd) (if (stringp output) (concat " >" output) "")))) (defconst tramp-inline-compress-commands @@ -4515,21 +4580,21 @@ Goes through the list `tramp-inline-compress-commands'." ;; Ad-hoc proxy definitions. (dolist (proxy (reverse (split-string hops tramp-postfix-hop-regexp 'omit))) - (let ((user (tramp-file-name-user item)) - (host (tramp-file-name-host item)) + (let ((user-domain (tramp-file-name-user-domain item)) + (host-port (tramp-file-name-host-port item)) (proxy (concat tramp-prefix-format proxy tramp-postfix-host-format))) (tramp-message vec 5 "Add proxy (\"%s\" \"%s\" \"%s\")" - (and (stringp host) (regexp-quote host)) - (and (stringp user) (regexp-quote user)) + (and (stringp host-port) (regexp-quote host-port)) + (and (stringp user-domain) (regexp-quote user-domain)) proxy) ;; Add the hop. (add-to-list 'tramp-default-proxies-alist - (list (and (stringp host) (regexp-quote host)) - (and (stringp user) (regexp-quote user)) - proxy)) + (list (and (stringp host-port) (regexp-quote host-port)) + (and (stringp user-domain) (regexp-quote user-domain)) + (propertize proxy 'tramp-ad-hoc t))) (setq item (tramp-dissect-file-name proxy)))) ;; Save the new value. (when (and hops tramp-save-ad-hoc-proxies) @@ -4543,11 +4608,15 @@ Goes through the list `tramp-inline-compress-commands'." proxy (eval (nth 2 item))) (when (and ;; Host. - (string-match (or (eval (nth 0 item)) "") - (or (tramp-file-name-host (car target-alist)) "")) + (string-match-p + (or (eval (nth 0 item)) "") + (or (tramp-file-name-host-port (car target-alist)) + "")) ;; User. - (string-match (or (eval (nth 1 item)) "") - (or (tramp-file-name-user (car target-alist)) ""))) + (string-match-p + (or (eval (nth 1 item)) "") + (or (tramp-file-name-user-domain (car target-alist)) + ""))) (if (null proxy) ;; No more hops needed. (setq choices nil) @@ -4575,25 +4644,24 @@ Goes through the list `tramp-inline-compress-commands'." "Method `%s' is not supported for multi-hops." (tramp-file-name-method item))))) - ;; In case the host name is not used for the remote shell - ;; command, the user could be misguided by applying a random - ;; host name. - (let* ((v (car target-alist)) - (method (tramp-file-name-method v)) - (host (tramp-file-name-host v))) - (unless - (or - ;; There are multi-hops. - (cdr target-alist) - ;; The host name is used for the remote shell command. - (member '("%h") (tramp-get-method-parameter v 'tramp-login-args)) - ;; The host is local. We cannot use `tramp-local-host-p' - ;; here, because it opens a connection as well. - (string-match tramp-local-host-regexp host)) - (tramp-error - v 'file-error - "Host `%s' looks like a remote host, `%s' can only use the local host" - host method))) + ;; Some methods ("su", "sg", "sudo", "doas", "ksu") do not use the + ;; host name in their command template. In this case, the remote + ;; file name must use either a local host name (first hop), or a + ;; host name matching the previous hop. + (let ((previous-host (or tramp-local-host-regexp ""))) + (setq choices target-alist) + (while (setq item (pop choices)) + (let ((host (tramp-file-name-host item))) + (unless + (or + ;; The host name is used for the remote shell command. + (member + '("%h") (tramp-get-method-parameter item 'tramp-login-args)) + ;; The host name must match previous hop. + (string-match-p previous-host host)) + (tramp-user-error + item "Host name `%s' does not match `%s'" host previous-host)) + (setq previous-host (concat "^" (regexp-quote host) "$"))))) ;; Result. target-alist)) @@ -4645,6 +4713,19 @@ Goes through the list `tramp-inline-compress-commands'." " -o ControlPersist=no"))))))))) tramp-ssh-controlmaster-options))) +(defun tramp-timeout-session (vec) + "Close the connection VEC after a session timeout. +If there is just some editing, retry it after 5 seconds." + (if (and tramp-locked tramp-locker + (tramp-file-name-equal-p vec (car tramp-current-connection))) + (progn + (tramp-message + vec 5 "Cannot timeout session, trying it again in %s seconds." 5) + (run-at-time 5 nil 'tramp-timeout-session vec)) + (tramp-message + vec 3 "Timeout session %s" (tramp-make-tramp-file-name vec 'localname)) + (tramp-cleanup-connection vec 'keep-debug))) + (defun tramp-maybe-open-connection (vec) "Maybe open a connection VEC. Does not do anything if a connection is already open, but re-opens the @@ -4727,7 +4808,8 @@ connection if a previous connection has died for some reason." (setenv "PS1" tramp-initial-end-of-output) (unless (stringp tramp-encoding-shell) (tramp-error vec 'file-error "`tramp-encoding-shell' not set")) - (let* ((target-alist (tramp-compute-multi-hops vec)) + (let* ((current-host (system-name)) + (target-alist (tramp-compute-multi-hops vec)) ;; We will apply `tramp-ssh-controlmaster-options' ;; only for the first hop. (options (tramp-ssh-controlmaster-options vec)) @@ -4750,13 +4832,12 @@ connection if a previous connection has died for some reason." tramp-encoding-command-interactive) (list tramp-encoding-shell)))))) - ;; Set sentinel and query flag. - (tramp-set-connection-property p "vector" vec) + ;; Set sentinel and query flag. Initialize variables. (set-process-sentinel p 'tramp-process-sentinel) + (process-put p 'vector vec) (process-put p 'adjust-window-size-function 'ignore) (set-process-query-on-exit-flag p nil) - (setq tramp-current-connection (cons vec (current-time)) - tramp-current-host (system-name)) + (setq tramp-current-connection (cons vec (current-time))) (tramp-message vec 6 "%s" (mapconcat 'identity (process-command p) " ")) @@ -4810,16 +4891,24 @@ connection if a previous connection has died for some reason." ;; Check, whether there is a restricted shell. (dolist (elt tramp-restricted-shell-hosts-alist) - (when (string-match elt tramp-current-host) + (when (string-match-p elt current-host) (setq r-shell t))) - - ;; Set variables for computing the prompt for - ;; reading password. - (setq tramp-current-method l-method - tramp-current-user l-user - tramp-current-domain l-domain - tramp-current-host l-host - tramp-current-port l-port) + (setq current-host l-host) + + ;; Set password prompt vector. + (tramp-set-connection-property + p "password-vector" + (make-tramp-file-name + :method l-method :user l-user :domain l-domain + :host l-host :port l-port)) + + ;; Set session timeout. + (when (tramp-get-method-parameter + hop 'tramp-session-timeout) + (tramp-set-connection-property + p "session-timeout" + (tramp-get-method-parameter + hop 'tramp-session-timeout))) ;; Add login environment. (when login-env @@ -4884,6 +4973,12 @@ connection if a previous connection has died for some reason." ;; Set connection-local variables. (tramp-set-connection-local-variables vec) + ;; Activate session timeout. + (when (tramp-get-connection-property p "session-timeout" nil) + (run-at-time + (tramp-get-connection-property p "session-timeout" nil) nil + 'tramp-timeout-session vec)) + ;; Make initial shell settings. (tramp-open-connection-setup-interactive-shell p vec) @@ -5032,92 +5127,91 @@ raises an error." "`%s' does not return a valid Lisp expression: `%s'" command (buffer-string)))))))) +;;;###tramp-autoload (defun tramp-convert-file-attributes (vec attr) "Convert `file-attributes' ATTR generated by perl script, stat or ls. Convert file mode bits to string and set virtual device number. Return ATTR." (when attr - ;; Remove color escape sequences from symlink. - (when (stringp (car attr)) - (while (string-match tramp-display-escape-sequence-regexp (car attr)) - (setcar attr (replace-match "" nil nil (car attr))))) - ;; Convert uid and gid. Use `tramp-unknown-id-integer' as - ;; indication of unusable value. - (when (and (numberp (nth 2 attr)) (< (nth 2 attr) 0)) - (setcar (nthcdr 2 attr) tramp-unknown-id-integer)) - (when (and (floatp (nth 2 attr)) - (<= (nth 2 attr) most-positive-fixnum)) - (setcar (nthcdr 2 attr) (round (nth 2 attr)))) - (when (and (numberp (nth 3 attr)) (< (nth 3 attr) 0)) - (setcar (nthcdr 3 attr) tramp-unknown-id-integer)) - (when (and (floatp (nth 3 attr)) - (<= (nth 3 attr) most-positive-fixnum)) - (setcar (nthcdr 3 attr) (round (nth 3 attr)))) - ;; Convert last access time. - (unless (listp (nth 4 attr)) - (setcar (nthcdr 4 attr) - (list (floor (nth 4 attr) 65536) - (floor (mod (nth 4 attr) 65536))))) - ;; Convert last modification time. - (unless (listp (nth 5 attr)) - (setcar (nthcdr 5 attr) - (list (floor (nth 5 attr) 65536) - (floor (mod (nth 5 attr) 65536))))) - ;; Convert last status change time. - (unless (listp (nth 6 attr)) - (setcar (nthcdr 6 attr) - (list (floor (nth 6 attr) 65536) - (floor (mod (nth 6 attr) 65536))))) - ;; Convert file size. - (when (< (nth 7 attr) 0) - (setcar (nthcdr 7 attr) -1)) - (when (and (floatp (nth 7 attr)) - (<= (nth 7 attr) most-positive-fixnum)) - (setcar (nthcdr 7 attr) (round (nth 7 attr)))) - ;; Convert file mode bits to string. - (unless (stringp (nth 8 attr)) - (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr))) + (save-match-data + ;; Remove color escape sequences from symlink. (when (stringp (car attr)) - (aset (nth 8 attr) 0 ?l))) - ;; Convert directory indication bit. - (when (string-match "^d" (nth 8 attr)) - (setcar attr t)) - ;; Convert symlink from `tramp-do-file-attributes-with-stat'. - (when (consp (car attr)) - (if (and (stringp (caar attr)) - (string-match ".+ -> .\\(.+\\)." (caar attr))) - (setcar attr (match-string 1 (caar attr))) - (setcar attr nil))) - ;; Set file's gid change bit. - (setcar (nthcdr 9 attr) - (if (numberp (nth 3 attr)) - (not (= (nth 3 attr) - (tramp-get-remote-gid vec 'integer))) - (not (string-equal - (nth 3 attr) - (tramp-get-remote-gid vec 'string))))) - ;; Convert inode. - (unless (listp (nth 10 attr)) - (setcar (nthcdr 10 attr) - (condition-case nil - (let ((high (nth 10 attr)) - middle low) - (if (<= high most-positive-fixnum) - (floor high) - ;; The low 16 bits. - (setq low (mod high #x10000) - high (/ high #x10000)) + (while (string-match tramp-display-escape-sequence-regexp (car attr)) + (setcar attr (replace-match "" nil nil (car attr))))) + ;; Convert uid and gid. Use `tramp-unknown-id-integer' as + ;; indication of unusable value. + (when (and (numberp (nth 2 attr)) (< (nth 2 attr) 0)) + (setcar (nthcdr 2 attr) tramp-unknown-id-integer)) + (when (and (floatp (nth 2 attr)) + (<= (nth 2 attr) most-positive-fixnum)) + (setcar (nthcdr 2 attr) (round (nth 2 attr)))) + (when (and (numberp (nth 3 attr)) (< (nth 3 attr) 0)) + (setcar (nthcdr 3 attr) tramp-unknown-id-integer)) + (when (and (floatp (nth 3 attr)) + (<= (nth 3 attr) most-positive-fixnum)) + (setcar (nthcdr 3 attr) (round (nth 3 attr)))) + ;; Convert last access time. + (unless (listp (nth 4 attr)) + (setcar (nthcdr 4 attr) (seconds-to-time (nth 4 attr)))) + ;; Convert last modification time. + (unless (listp (nth 5 attr)) + (setcar (nthcdr 5 attr) (seconds-to-time (nth 5 attr)))) + ;; Convert last status change time. + (unless (listp (nth 6 attr)) + (setcar (nthcdr 6 attr) (seconds-to-time (nth 6 attr)))) + ;; Convert file size. + (when (< (nth 7 attr) 0) + (setcar (nthcdr 7 attr) -1)) + (when (and (floatp (nth 7 attr)) + (<= (nth 7 attr) most-positive-fixnum)) + (setcar (nthcdr 7 attr) (round (nth 7 attr)))) + ;; Convert file mode bits to string. + (unless (stringp (nth 8 attr)) + (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr))) + (when (stringp (car attr)) + (aset (nth 8 attr) 0 ?l))) + ;; Convert directory indication bit. + (when (string-match-p "^d" (nth 8 attr)) + (setcar attr t)) + ;; Convert symlink from `tramp-do-file-attributes-with-stat'. + ;; Decode also multibyte string. + (when (consp (car attr)) + (setcar attr + (and (stringp (caar attr)) + (string-match ".+ -> .\\(.+\\)." (caar attr)) + (decode-coding-string + (match-string 1 (caar attr)) 'utf-8)))) + ;; Set file's gid change bit. + (setcar (nthcdr 9 attr) + (if (numberp (nth 3 attr)) + (not (= (nth 3 attr) + (tramp-get-remote-gid vec 'integer))) + (not (string-equal + (nth 3 attr) + (tramp-get-remote-gid vec 'string))))) + ;; Convert inode. + (when (floatp (nth 10 attr)) + (setcar (nthcdr 10 attr) + (condition-case nil + (let ((high (nth 10 attr)) + middle low) (if (<= high most-positive-fixnum) - (cons (floor high) (floor low)) - ;; The middle 24 bits. - (setq middle (mod high #x1000000) - high (/ high #x1000000)) - (cons (floor high) (cons (floor middle) (floor low)))))) - ;; Inodes can be incredible huge. We must hide this. - (error (tramp-get-inode vec))))) - ;; Set virtual device number. - (setcar (nthcdr 11 attr) - (tramp-get-device vec)) + (floor high) + ;; The low 16 bits. + (setq low (mod high #x10000) + high (/ high #x10000)) + (if (<= high most-positive-fixnum) + (cons (floor high) (floor low)) + ;; The middle 24 bits. + (setq middle (mod high #x1000000) + high (/ high #x1000000)) + (cons (floor high) + (cons (floor middle) (floor low)))))) + ;; Inodes can be incredible huge. We must hide this. + (error (tramp-get-inode vec))))) + ;; Set virtual device number. + (setcar (nthcdr 11 attr) + (tramp-get-device vec))) attr)) (defun tramp-shell-case-fold (string) @@ -5137,9 +5231,9 @@ Return ATTR." (host (tramp-file-name-host vec)) (localname (directory-file-name (tramp-file-name-unquote-localname vec)))) - (when (string-match tramp-ipv6-regexp host) + (when (string-match-p tramp-ipv6-regexp host) (setq host (format "[%s]" host))) - (unless (string-match "ftp$" method) + (unless (string-match-p "ftp$" method) (setq localname (tramp-shell-quote-argument localname))) (cond ((tramp-get-method-parameter vec 'tramp-remote-copy-program) @@ -5244,14 +5338,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 'nohop)) x)) remote-path))))) @@ -5264,8 +5351,8 @@ Nonexistent directories are removed from spec." (with-current-buffer (tramp-get-connection-buffer vec) (while candidates (goto-char (point-min)) - (if (string-match (format "^%s\r?$" (regexp-quote (car candidates))) - (buffer-string)) + (if (string-match-p (format "^%s\r?$" (regexp-quote (car candidates))) + (buffer-string)) (setq locale (car candidates) candidates nil) (setq candidates (cdr candidates))))) @@ -5285,7 +5372,7 @@ Nonexistent directories are removed from spec." ;; Check parameters. On busybox, "ls" output coloring is ;; enabled by default sometimes. So we try to disable it ;; when possible. $LS_COLORING is not supported there. - ;; Some "ls" versions are sensible wrt the order of + ;; Some "ls" versions are sensitive to the order of ;; arguments, they fail when "-al" is after the ;; "--color=never" argument (for example on FreeBSD). (when (tramp-send-command-and-check @@ -5298,36 +5385,23 @@ Nonexistent directories are removed from spec." (setq dl (cdr dl)))))) (tramp-error vec 'file-error "Couldn't find a proper `ls' command")))) -(defun tramp-get-ls-command-with-dired (vec) - "Check, whether the remote `ls' command supports the --dired option." - (save-match-data - (with-tramp-connection-property vec "ls-dired" - (tramp-message vec 5 "Checking, whether `ls --dired' works") - ;; Some "ls" versions are sensible wrt the order of arguments, - ;; they fail when "-al" is after the "--dired" argument (for - ;; example on FreeBSD). - (tramp-send-command-and-check - vec (format "%s --dired -al /dev/null" (tramp-get-ls-command vec)))))) - -(defun tramp-get-ls-command-with-quoting-style (vec) - "Check, whether the remote `ls' command supports the --quoting-style option." - (save-match-data - (with-tramp-connection-property vec "ls-quoting-style" - (tramp-message vec 5 "Checking, whether `ls --quoting-style=shell' works") +(defun tramp-get-ls-command-with (vec option) + "Return OPTION, if the remote `ls' command supports the OPTION option." + (with-tramp-connection-property vec (concat "ls" option) + (tramp-message vec 5 "Checking, whether `ls %s' works" option) + ;; Some "ls" versions are sensitive to the order of arguments, + ;; they fail when "-al" is after the "--dired" argument (for + ;; example on FreeBSD). Busybox does not support this kind of + ;; options. + (and + (not (tramp-send-command-and-check - vec (format "%s --quoting-style=shell -al /dev/null" - (tramp-get-ls-command vec)))))) - -(defun tramp-get-ls-command-with-w-option (vec) - "Check, whether the remote `ls' command supports the -w option." - (save-match-data - (with-tramp-connection-property vec "ls-w-option" - (tramp-message vec 5 "Checking, whether `ls -w' works") - ;; Option "-w" is available on BSD systems. No argument is - ;; given, because this could return wrong results in case "ls" - ;; supports the "-w NUM" argument, as for busyboxes. - (tramp-send-command-and-check - vec (format "%s -alw" (tramp-get-ls-command vec)))))) + vec + (format + "%s --help 2>&1 | grep -iq busybox" (tramp-get-ls-command vec)))) + (tramp-send-command-and-check + vec (format "%s %s -al /dev/null" (tramp-get-ls-command vec) option)) + option))) (defun tramp-get-test-command (vec) "Determine remote `test' command." @@ -5349,7 +5423,7 @@ Nonexistent directories are removed from spec." vec (format "( %s / -nt / )" (tramp-get-test-command vec))) (with-current-buffer (tramp-get-buffer vec) (goto-char (point-min)) - (when (looking-at (regexp-quote tramp-end-of-output)) + (when (looking-at-p (regexp-quote tramp-end-of-output)) (format "%s %%s -nt %%s" (tramp-get-test-command vec))))) (progn (tramp-send-command @@ -5411,7 +5485,7 @@ Nonexistent directories are removed from spec." tmp (tramp-send-command-and-read vec (format "%s -c '(\"%%N\" %%s)' /" result) 'noerror)) (unless (and (listp tmp) (stringp (car tmp)) - (string-match "^\\(`/'\\|‘/’\\)$" (car tmp)) + (string-match-p "^\\(`/'\\|‘/’\\)$" (car tmp)) (integerp (cadr tmp))) (setq result nil))) result))) @@ -5456,7 +5530,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." "%s -t %s %s" result (format-time-string "%Y%m%d%H%M.%S") - (file-remote-p tmpfile 'localname)))) + (tramp-compat-file-local-name tmpfile)))) (delete-file tmpfile)) result))) @@ -5471,6 +5545,12 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." vec (format "%s --block-size=1 --output=size,used,avail /" result)) result)))) +(defun tramp-get-remote-gio-monitor (vec) + "Determine remote `gio-monitor' command." + (with-tramp-connection-property vec "gio-monitor" + (tramp-message vec 5 "Finding a suitable `gio-monitor' command") + (tramp-find-executable vec "gio" (tramp-get-remote-path vec) t t))) + (defun tramp-get-remote-gvfs-monitor-dir (vec) "Determine remote `gvfs-monitor-dir' command." (with-tramp-connection-property vec "gvfs-monitor-dir" @@ -5656,14 +5736,14 @@ function cell is returned to be applied on a buffer." (tramp-find-inline-encoding vec) (tramp-get-connection-property (tramp-get-connection-process vec) prop nil))) - (prop1 (if (string-match "encoding" prop) + (prop1 (if (string-match-p "encoding" prop) "inline-compress" "inline-decompress")) compress) ;; The connection property might have been cached. So we must ;; send the script to the remote side - maybe. - (when (and coding (symbolp coding) (string-match "remote" prop)) + (when (and coding (symbolp coding) (string-match-p "remote" prop)) (let ((name (symbol-name coding))) - (while (string-match (regexp-quote "-") name) + (while (string-match "-" name) (setq name (replace-match "_" nil t name))) (tramp-maybe-send-script vec (symbol-value coding) name) (setq coding name))) @@ -5673,7 +5753,7 @@ function cell is returned to be applied on a buffer." ;; Return the value. (cond ((and compress (symbolp coding)) - (if (string-match "decompress" prop1) + (if (string-match-p "decompress" prop1) `(lambda (beg end) (,coding beg end) (let ((coding-system-for-write 'binary) @@ -5692,16 +5772,16 @@ function cell is returned to be applied on a buffer." (,coding (point-min) (point-max))))) ((symbolp coding) coding) - ((and compress (string-match "decoding" prop)) + ((and compress (string-match-p "decoding" prop)) (format ;; Windows shells need the program file name after ;; the pipe symbol be quoted if they use forward ;; slashes as directory separators. (cond - ((and (string-match "local" prop) + ((and (string-match-p "local" prop) (memq system-type '(windows-nt))) "(%s | \"%s\")") - ((string-match "local" prop) "(%s | %s)") + ((string-match-p "local" prop) "(%s | %s)") (t "(%s | %s >%%s)")) coding compress)) (compress @@ -5709,14 +5789,14 @@ function cell is returned to be applied on a buffer." ;; Windows shells need the program file name after ;; the pipe symbol be quoted if they use forward ;; slashes as directory separators. - (if (and (string-match "local" prop) + (if (and (string-match-p "local" prop) (memq system-type '(windows-nt))) "(%s <%%s | \"%s\")" "(%s <%%s | %s)") compress coding)) - ((string-match "decoding" prop) + ((string-match-p "decoding" prop) (cond - ((string-match "local" prop) (format "%s" coding)) + ((string-match-p "local" prop) (format "%s" coding)) (t (format "%s >%%s" coding)))) (t (format "%s <%%s" coding))))))) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 5bcb082626f..5b7998ac970 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -27,6 +27,7 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) (require 'tramp) ;; Define SMB method ... @@ -119,6 +120,7 @@ call, letting the SMB client use the default one." "ERRnoaccess" "ERRnomem" "ERRnosuchshare" + ;; See /usr/include/samba-4.0/core/ntstatus.h. ;; Windows 4.0 (Windows NT), Windows 5.0 (Windows 2000), ;; Windows 5.1 (Windows XP), Windows 5.2 (Windows Server 2003), ;; Windows 6.0 (Windows Vista), Windows 6.1 (Windows 7), @@ -129,6 +131,7 @@ call, letting the SMB client use the default one." "NT_STATUS_CANNOT_DELETE" "NT_STATUS_CONNECTION_DISCONNECTED" "NT_STATUS_CONNECTION_REFUSED" + "NT_STATUS_CONNECTION_RESET" "NT_STATUS_DIRECTORY_NOT_EMPTY" "NT_STATUS_DUPLICATE_NAME" "NT_STATUS_FILE_IS_A_DIRECTORY" @@ -149,6 +152,7 @@ call, letting the SMB client use the default one." "NT_STATUS_OBJECT_PATH_SYNTAX_BAD" "NT_STATUS_PASSWORD_MUST_CHANGE" "NT_STATUS_RESOURCE_NAME_NOT_FOUND" + "NT_STATUS_REVISION_MISMATCH" "NT_STATUS_SHARING_VIOLATION" "NT_STATUS_TRUSTED_RELATIONSHIP_FAILURE" "NT_STATUS_UNSUCCESSFUL" @@ -225,11 +229,12 @@ See `tramp-actions-before-shell' for more info.") . tramp-handle-directory-files-and-attributes) (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) + (exec-path . ignore) (expand-file-name . tramp-smb-handle-expand-file-name) - (file-accessible-directory-p . tramp-smb-handle-file-directory-p) + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . tramp-smb-handle-file-acl) (file-attributes . tramp-smb-handle-file-attributes) - (file-directory-p . tramp-smb-handle-file-directory-p) + (file-directory-p . tramp-handle-file-directory-p) (file-file-equal-p . tramp-handle-file-equal-p) (file-executable-p . tramp-handle-file-exists-p) (file-exists-p . tramp-handle-file-exists-p) @@ -257,7 +262,6 @@ See `tramp-actions-before-shell' for more info.") (file-truename . tramp-handle-file-truename) (file-writable-p . tramp-smb-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) - ;; `find-file-noselect' performed by default handler. ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-smb-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) @@ -316,8 +320,9 @@ This can be used to disable echo etc." ;;;###tramp-autoload (defsubst tramp-smb-file-name-p (filename) "Check if it's a filename for SMB servers." - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-smb-method)) + (and (tramp-tramp-file-p filename) + (string= (tramp-file-name-method (tramp-dissect-file-name filename)) + tramp-smb-method))) ;;;###tramp-autoload (defun tramp-smb-file-name-handler (operation &rest args) @@ -365,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 @@ -444,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 @@ -521,7 +519,7 @@ pass to the OPERATION." (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" v) + (process-put p 'vector v) (process-put p 'adjust-window-size-function 'ignore) (set-process-query-on-exit-flag p nil) (tramp-process-actions p v nil tramp-smb-actions-with-tar) @@ -531,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. @@ -549,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 @@ -595,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)) @@ -630,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\"" @@ -656,8 +654,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\"" @@ -679,7 +677,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when match (setq result (delete nil - (mapcar (lambda (x) (when (string-match match x) x)) + (mapcar (lambda (x) (when (string-match-p match x) x)) result)))) ;; Append directory. (when full @@ -718,8 +716,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; No tilde characters in file name, do normal ;; `expand-file-name' (this does "/./" and "/../"). (tramp-make-tramp-file-name - method user domain host port - (tramp-run-real-handler 'expand-file-name (list localname)))))) + v (tramp-run-real-handler 'expand-file-name (list localname)))))) (defun tramp-smb-action-get-acl (proc vec) "Read ACL data from connection buffer." @@ -731,74 +728,68 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (widen) (tramp-message vec 10 "\n%s" (buffer-string)) (goto-char (point-min)) - (while (and (not (eobp)) (not (looking-at "^REVISION:"))) + (while (and (not (eobp)) (not (looking-at-p "^REVISION:"))) (forward-line) (delete-region (point-min) (point))) - (while (and (not (eobp)) (looking-at "^.+:.+")) + (while (and (not (eobp)) (looking-at-p "^.+:.+")) (forward-line)) (delete-region (point) (point-max)) (throw 'tramp-action 'ok)))) (defun tramp-smb-handle-file-acl (filename) "Like `file-acl' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-tramp-file-property v localname "file-acl" - (when (executable-find tramp-smb-acl-program) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - - (let* ((share (tramp-smb-get-share v)) - (localname (replace-regexp-in-string - "\\\\" "/" (tramp-smb-get-localname v))) + (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)) + (if (not (zerop (length user))) + (setq args (append args (list "-U" user))) + (setq args (append args (list "-N")))) - ;; 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))))))) + (when domain (setq args (append args (list "-W" domain)))) + (when port (setq args (append args (list "-p" port)))) + (when tramp-smb-conf + (setq args (append args (list "-s" tramp-smb-conf)))) + (setq + args + (append args (list (tramp-unquote-shell-quote-argument localname) + "2>/dev/null"))) + + (unwind-protect + (with-temp-buffer + ;; Set the transfer process properties. + (tramp-set-connection-property + v "process-name" (buffer-name (current-buffer))) + (tramp-set-connection-property + v "process-buffer" (current-buffer)) + + ;; Use an asynchronous process. By this, password can + ;; be handled. + (let ((p (apply + 'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + tramp-smb-acl-program args))) + + (tramp-message + v 6 "%s" (mapconcat 'identity (process-command p) " ")) + (process-put p 'vector v) + (process-put p 'adjust-window-size-function 'ignore) + (set-process-query-on-exit-flag p nil) + (tramp-process-actions p v nil tramp-smb-actions-get-acl) + (when (> (point-max) (point-min)) + (substring-no-properties (buffer-string))))) + + ;; Reset the transfer process properties. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer")))))))) (defun tramp-smb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." @@ -825,19 +816,19 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Check result. (when entry - (list (and (string-match "d" (nth 1 entry)) - t) ;0 file type - -1 ;1 link count - uid ;2 uid - gid ;3 gid - '(0 0) ;4 atime - (nth 3 entry) ;5 mtime - '(0 0) ;6 ctime - (nth 2 entry) ;7 size - (nth 1 entry) ;8 mode - nil ;9 gid weird - inode ;10 inode number - device)))))))) ;11 file system number + (list (and (string-match-p "d" (nth 1 entry)) + t) ;0 file type + -1 ;1 link count + uid ;2 uid + gid ;3 gid + tramp-time-dont-know ;4 atime + (nth 3 entry) ;5 mtime + tramp-time-dont-know ;6 ctime + (nth 2 entry) ;7 size + (nth 1 entry) ;8 mode + nil ;9 gid weird + inode ;10 inode number + device)))))))) ;11 file system number (defun tramp-smb-do-file-attributes-with-stat (vec &optional id-format) "Implement `file-attributes' for Tramp files using stat command." @@ -915,13 +906,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (list id link uid gid atime mtime ctime size mode nil inode (tramp-get-device vec)))))))) -(defun tramp-smb-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - (and (file-exists-p filename) - (eq ?d - (aref (tramp-compat-file-attribute-modes (file-attributes filename)) - 0)))) - (defun tramp-smb-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name (file-truename filename) nil @@ -949,15 +933,14 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." filename (with-parsed-tramp-file-name (expand-file-name directory) nil (with-tramp-file-property v localname "file-name-all-completions" - (save-match-data - (delete-dups - (mapcar - (lambda (x) - (list - (if (string-match "d" (nth 1 x)) - (file-name-as-directory (nth 0 x)) - (nth 0 x)))) - (tramp-smb-get-file-entries directory)))))))) + (delete-dups + (mapcar + (lambda (x) + (list + (if (string-match-p "d" (nth 1 x)) + (file-name-as-directory (nth 0 x)) + (nth 0 x)))) + (tramp-smb-get-file-entries directory))))))) (defun tramp-smb-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." @@ -972,21 +955,19 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (goto-char (point-min)) (forward-line) (when (looking-at - (concat "[[:space:]]*\\([[:digit:]]+\\)" - " blocks of size \\([[:digit:]]+\\)" - "\\. \\([[:digit:]]+\\) blocks available")) - (setq blocksize (string-to-number (concat (match-string 2) "e0")) - total (* blocksize - (string-to-number (concat (match-string 1) "e0"))) - avail (* blocksize - (string-to-number (concat (match-string 3) "e0"))))) + (eval-when-compile + (concat "[[:space:]]*\\([[:digit:]]+\\)" + " blocks of size \\([[:digit:]]+\\)" + "\\. \\([[:digit:]]+\\) blocks available"))) + (setq blocksize (string-to-number (match-string 2)) + total (* blocksize (string-to-number (match-string 1))) + avail (* blocksize (string-to-number (match-string 3))))) (forward-line) (when (looking-at "Total number of bytes: \\([[:digit:]]+\\)") ;; The used number of bytes is not part of the result. As ;; side effect, we store it as file property. (tramp-set-file-property - v localname "used-bytes" - (string-to-number (concat (match-string 1) "e0")))) + v localname "used-bytes" (string-to-number (match-string 1)))) ;; Result. (when (and total avail) (list total (- total avail) avail))))))) @@ -994,7 +975,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (defun tramp-smb-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." (if (file-exists-p filename) - (string-match + (string-match-p "w" (or (tramp-compat-file-attribute-modes (file-attributes filename)) "")) (let ((dir (file-name-directory filename))) @@ -1046,7 +1027,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Check for matching entries. (mapcar (lambda (x) - (when (string-match + (when (string-match-p (format "^%s" base) (nth 0 x)) x)) entries) @@ -1058,14 +1039,14 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (sort entries (lambda (x y) - (if (string-match "t" switches) + (if (string-match-p "t" switches) ;; Sort by date. (time-less-p (nth 3 y) (nth 3 x)) ;; Sort by name. (string-lessp (nth 0 x) (nth 0 y)))))) ;; Handle "-F" switch. - (when (string-match "F" switches) + (when (string-match-p "F" switches) (mapc (lambda (x) (when (not (zerop (length (car x)))) @@ -1094,7 +1075,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (expand-file-name (nth 0 x) (file-name-directory filename)) 'string))))) - (when (string-match "l" switches) + (when (string-match-p "l" switches) (insert (format "%10s %3d %-8s %-8s %8s %s " @@ -1104,8 +1085,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (or (tramp-compat-file-attribute-group-id attr) "nogroup") (or (tramp-compat-file-attribute-size attr) (nth 2 x)) (format-time-string - (if (time-less-p (time-subtract (current-time) (nth 3 x)) - tramp-half-a-year) + (if (time-less-p + ;; Half a year. + (time-since (nth 3 x)) (days-to-time 183)) "%b %e %R" "%b %e %Y") (nth 3 x))))) ; date @@ -1124,7 +1106,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (put-text-property start (point) 'dired-filename t)) ;; Insert symlink. - (when (and (string-match "l" switches) + (when (and (string-match-p "l" switches) (stringp (tramp-compat-file-attribute-type attr))) (insert " -> " (tramp-compat-file-attribute-type attr)))) @@ -1139,18 +1121,17 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (unless (file-name-absolute-p dir) (setq dir (expand-file-name dir default-directory))) (with-parsed-tramp-file-name dir nil - (save-match-data - (let* ((ldir (file-name-directory dir))) - ;; Make missing directory parts. - (when (and parents - (tramp-smb-get-share v) - (not (file-directory-p ldir))) - (make-directory ldir parents)) - ;; Just do it. - (when (file-directory-p ldir) - (make-directory-internal dir)) - (unless (file-directory-p dir) - (tramp-error v 'file-error "Couldn't make directory %s" dir)))))) + (let* ((ldir (file-name-directory dir))) + ;; Make missing directory parts. + (when (and parents + (tramp-smb-get-share v) + (not (file-directory-p ldir))) + (make-directory ldir parents)) + ;; Just do it. + (when (file-directory-p ldir) + (make-directory-internal dir)) + (unless (file-directory-p dir) + (tramp-error v 'file-error "Couldn't make directory %s" dir))))) (defun tramp-smb-handle-make-directory-internal (directory) "Like `make-directory-internal' for Tramp files." @@ -1158,21 +1139,19 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (unless (file-name-absolute-p directory) (setq directory (expand-file-name directory default-directory))) (with-parsed-tramp-file-name directory nil - (save-match-data - (let* ((file (tramp-smb-get-localname v))) - (when (file-directory-p (file-name-directory directory)) - (tramp-smb-send-command - v - (if (tramp-smb-get-cifs-capabilities v) - (format "posix_mkdir \"%s\" %o" file (default-file-modes)) - (format "mkdir \"%s\"" file))) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)) - (unless (file-directory-p directory) - (tramp-error - v 'file-error "Couldn't make directory %s" directory)))))) + (let* ((file (tramp-smb-get-localname v))) + (when (file-directory-p (file-name-directory directory)) + (tramp-smb-send-command + v + (if (tramp-smb-get-cifs-capabilities v) + (format "posix_mkdir \"%s\" %o" file (default-file-modes)) + (format "mkdir \"%s\"" file))) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname)) + (unless (file-directory-p directory) + (tramp-error v 'file-error "Couldn't make directory %s" directory))))) (defun tramp-smb-handle-make-symbolic-link (target linkname &optional ok-if-already-exists) @@ -1215,8 +1194,8 @@ component is used as the target of the symlink." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (unless (tramp-smb-send-command @@ -1226,7 +1205,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) @@ -1251,8 +1230,7 @@ component is used as the target of the symlink." (setq input (with-parsed-tramp-file-name infile nil localname)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) - tmpinput - (tramp-make-tramp-file-name method user domain host port input)) + tmpinput (tramp-make-tramp-file-name v input)) (copy-file infile tmpinput t)) ;; Transform input into a filename powershell does understand. (setq input (format "//%s%s" host input))) @@ -1333,14 +1311,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) @@ -1376,10 +1354,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)) @@ -1409,15 +1387,9 @@ 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))) @@ -1459,7 +1431,7 @@ component is used as the target of the symlink." (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" v) + (process-put p 'vector v) (process-put p 'adjust-window-size-function 'ignore) (set-process-query-on-exit-flag p nil) (tramp-process-actions p v nil tramp-smb-actions-set-acl) @@ -1478,14 +1450,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 @@ -1535,13 +1507,13 @@ component is used as the target of the symlink." ;; Save exit. (with-current-buffer (tramp-get-connection-buffer v) - (if (string-match tramp-temp-buffer-name (buffer-name)) + (if (string-match-p tramp-temp-buffer-name (buffer-name)) (progn (set-process-buffer (tramp-get-connection-process v) nil) (kill-buffer (current-buffer))) (set-buffer-modified-p bmp))) - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil))))) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer"))))) (defun tramp-smb-handle-substitute-in-file-name (filename) "Like `handle-substitute-in-file-name' for Tramp files. @@ -1574,8 +1546,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)) @@ -1644,6 +1616,13 @@ If VEC has no cifs capabilities, exchange \"/\" by \"\\\\\"." (when (string-match "\\(\\$\\$\\)\\(/\\|$\\)" localname) (setq localname (replace-match "$" nil nil localname 1))) + ;; A period followed by a space, or trailing periods and spaces, + ;; are not supported. + (when (string-match-p "\\. \\|\\.$\\| $" localname) + (tramp-error + vec 'file-error + "Invalid file name %s" (tramp-make-tramp-file-name vec localname))) + localname))) ;; Share names of a host are cached. It is very unlikely that the @@ -1793,7 +1772,7 @@ Result is the list (LOCALNAME MODE SIZE MTIME)." (cl-return)) ;; weekday. - (if (string-match "\\(\\w+\\)$" line) + (if (string-match-p "\\(\\w+\\)$" line) (setq line (substring line 0 -5)) (cl-return)) @@ -1814,12 +1793,12 @@ Result is the list (LOCALNAME MODE SIZE MTIME)." (if (string-match "\\([ACDEHNORrsSTV]+\\)?$" line) (setq mode (or (match-string 1 line) "") - mode (save-match-data (format + mode (format "%s%s" - (if (string-match "D" mode) "d" "-") + (if (string-match-p "D" mode) "d" "-") (mapconcat (lambda (_x) "") " " - (concat "r" (if (string-match "R" mode) "-" "w") "x")))) + (concat "r" (if (string-match-p "R" mode) "-" "w") "x"))) line (substring line 0 -6)) (cl-return)) @@ -1835,7 +1814,7 @@ Result is the list (LOCALNAME MODE SIZE MTIME)." sec min hour day (cdr (assoc (downcase month) parse-time-months)) year) - '(0 0))) + tramp-time-dont-know)) (list localname mode size mtime)))) (defun tramp-smb-get-cifs-capabilities (vec) @@ -1908,8 +1887,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))) @@ -1986,17 +1965,10 @@ If ARGUMENT is non-nil, use it as argument for (tramp-message vec 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" vec) + (process-put p 'vector vec) (process-put p 'adjust-window-size-function 'ignore) (set-process-query-on-exit-flag p nil) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method tramp-smb-method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - (condition-case err (let (tramp-message-show-message) ;; Play login scenario. @@ -2017,8 +1989,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)))) @@ -2111,7 +2083,6 @@ Returns nil if an error message has appeared." (defun tramp-smb-call-winexe (vec) "Apply a remote command, if possible, using `tramp-smb-winexe-program'." - ;; Check for program. (unless (executable-find tramp-smb-winexe-program) (tramp-error diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 5fa9f9a44d4..a44abfdcbbd 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -7,6 +7,8 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp +;; Version: 2.4.1-pre +;; Package-Requires: ((emacs "24.1")) ;; This file is part of GNU Emacs. @@ -35,8 +37,6 @@ ;; Notes: ;; ----- ;; -;; This package only works for Emacs 24.1 and higher. -;; ;; Also see the todo list at the bottom of this file. ;; ;; The current version of Tramp can be retrieved from the following URL: @@ -56,9 +56,11 @@ ;;; Code: (require 'tramp-compat) +(require 'trampver) ;; Pacify byte-compiler. (require 'cl-lib) +(declare-function netrc-parse "netrc") (defvar auto-save-file-name-transforms) (defvar eshell-path-env) (defvar ls-lisp-use-insert-directory-program) @@ -167,6 +169,7 @@ See the variable `tramp-encoding-shell' for more information." This is a list of entries of the form (NAME PARAM1 PARAM2 ...). Each NAME stands for a remote access method. Each PARAM is a pair of the form (KEY VALUE). The following KEYs are defined: + * `tramp-remote-shell' This specifies the shell to use on the remote host. This MUST be a Bourne-like shell. It is normally not necessary to @@ -175,19 +178,23 @@ pair of the form (KEY VALUE). The following KEYs are defined: for it. Also note that \"/bin/sh\" exists on all Unixen, this might not be true for the value that you decide to use. You Have Been Warned. + * `tramp-remote-shell-login' This specifies the arguments to let `tramp-remote-shell' run as a login shell. It defaults to (\"-l\"), but some shells, like ksh, require another argument. See `tramp-connection-properties' for a way to overwrite the default value. + * `tramp-remote-shell-args' For implementation of `shell-command', this specifies the arguments to let `tramp-remote-shell' run a single command. + * `tramp-login-program' This specifies the name of the program to use for logging in to the remote host. This may be the name of rsh or a workalike program, or the name of telnet or a workalike, or the name of su or a workalike. + * `tramp-login-args' This specifies the list of arguments to pass to the above mentioned program. Please note that this is a list of list of arguments, @@ -203,55 +210,88 @@ pair of the form (KEY VALUE). The following KEYs are defined: `tramp-make-tramp-temp-file'. \"%k\" indicates the keep-date parameter of a program, if exists. \"%c\" adds additional `tramp-ssh-controlmaster-options' options for the first hop. + The existence of `tramp-login-args', combined with the absence of + `tramp-copy-args', is an indication that the method is capable of + multi-hops. + * `tramp-login-env' A list of environment variables and their values, which will be set when calling `tramp-login-program'. + * `tramp-async-args' When an asynchronous process is started, we know already that the connection works. Therefore, we can pass additional parameters to suppress diagnostic messages, in order not to tamper the process output. + * `tramp-copy-program' This specifies the name of the program to use for remotely copying the file; this might be the absolute filename of scp or the name of a workalike program. It is always applied on the local host. + * `tramp-copy-args' This specifies the list of parameters to pass to the above mentioned program, the hints for `tramp-login-args' also apply here. + * `tramp-copy-env' A list of environment variables and their values, which will be set when calling `tramp-copy-program'. + * `tramp-remote-copy-program' The listener program to be applied on remote side, if needed. + * `tramp-remote-copy-args' The list of parameters to pass to the listener program, the hints for `tramp-login-args' also apply here. Additionally, \"%r\" could be used here and in `tramp-copy-args'. It denotes a randomly chosen port for the remote listener. + * `tramp-copy-keep-date' This specifies whether the copying program when the preserves the timestamp of the original file. + * `tramp-copy-keep-tmpfile' This specifies whether a temporary local file shall be kept for optimization reasons (useful for \"rsync\" methods). + * `tramp-copy-recursive' Whether the operation copies directories recursively. + * `tramp-default-port' The default port of a method. + * `tramp-tmpdir' A directory on the remote host for temporary files. If not specified, \"/tmp\" is taken as default. + * `tramp-connection-timeout' This is the maximum time to be spent for establishing a connection. In general, the global default value shall be used, but for some methods, like \"su\" or \"sudo\", a shorter timeout might be desirable. + + * `tramp-session-timeout' + How long a Tramp connection keeps open before being disconnected. + This is useful for methods like \"su\" or \"sudo\", which + shouldn't run an open connection in the background forever. + * `tramp-case-insensitive' Whether the remote file system handles file names case insensitive. Only a non-nil value counts, the default value nil means to perform further checks on the remote host. See `tramp-connection-properties' for a way to overwrite this. + * `tramp-mount-args' + * `tramp-copyto-args' + * `tramp-moveto-args' + * `tramp-about-args' + These parameters, a list of list like `tramp-login-args', are used + for the \"rclone\" method, and are appended to the respective + \"rclone\" commands. In general, they shouldn't be changed inside + `tramp-methods'; it is recommended to change their values via + `tramp-connection-properties'. Unlike `tramp-login-args' there is + no pattern replacement. + What does all this mean? Well, you should specify `tramp-login-program' for all methods; this program is used to log in to the remote site. Then, there are two ways to actually transfer the files between the local and the @@ -378,11 +418,17 @@ empty string for the method name." This is an alist of items (HOST USER PROXY). The first matching item specifies the proxy to be passed for a file name located on a remote target matching USER@HOST. HOST and USER are regular -expressions. PROXY must be a Tramp filename without a localname -part. Method and user name on PROXY are optional, which is -interpreted with the default values. PROXY can contain the -patterns %h and %u, which are replaced by the strings matching -HOST or USER, respectively. +expressions, which could also cover a domain (USER%DOMAIN) or +port (HOST#PORT). PROXY must be a Tramp filename without a +localname part. Method and user name on PROXY are optional, +which is interpreted with the default values. + +PROXY can contain the patterns %h and %u, which are replaced by +the strings matching HOST or USER (without DOMAIN and PORT parts), +respectively. + +If an entry is added while parsing ad-hoc hop definitions, PROXY +carries the non-nil text property `tramp-ad-hoc'. HOST, USER or PROXY could also be Lisp forms, which will be evaluated. The result must be a string or nil, which is @@ -411,13 +457,18 @@ host runs a registered shell, it shall be added to this list, too." :type '(repeat (regexp :tag "Host regexp"))) ;;;###tramp-autoload -(defconst tramp-local-host-regexp +(defcustom tramp-local-host-regexp (concat "\\`" (regexp-opt (list "localhost" "localhost6" (system-name) "127.0.0.1" "::1") t) "\\'") - "Host names which are regarded as local host.") + "Host names which are regarded as local host. +If the local host runs a chrooted environment, set this to nil." + :version "27.1" + :group 'tramp + :type '(choice (const :tag "Chrooted environment" nil) + (regexp :tag "Host regexp"))) (defvar tramp-completion-function-alist nil "Alist of methods for remote files. @@ -660,7 +711,7 @@ Used in user option `tramp-syntax'. There are further variables to be set, depending on VALUE." ;; Check allowed values. (unless (memq value (tramp-syntax-values)) - (tramp-compat-user-error "Wrong `tramp-syntax' %s" tramp-syntax)) + (tramp-user-error "Wrong `tramp-syntax' %s" tramp-syntax)) ;; Cleanup existing buffers. (unless (eq (symbol-value symbol) value) (tramp-cleanup-all-buffers)) @@ -882,7 +933,7 @@ Used in `tramp-make-tramp-file-name'.") "Regexp matching delimiter between host names and localnames. Derived from `tramp-postfix-host-format'.") -(defconst tramp-localname-regexp ".*$" +(defconst tramp-localname-regexp "[^\n\r]*\\'" "Regexp matching localnames.") (defconst tramp-unknown-id-string "UNKNOWN" @@ -956,6 +1007,13 @@ This regexp should match Tramp file names but no other file names. When calling `tramp-register-file-name-handlers', the initial value is overwritten by the car of `tramp-file-name-structure'.") +;;;###autoload +(defcustom tramp-ignored-file-name-regexp nil + "Regular expression matching file names that are not under Tramp’s control." + :version "27.1" + :group 'tramp + :type '(choice (const nil) regexp)) + (defconst tramp-completion-file-name-regexp-default (concat "\\`/\\(" @@ -1149,24 +1207,14 @@ 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.") +(defvar tramp-password-save-function nil + "Password save function. +Will be called once the password has been verified by successful +authentication.") + (defconst tramp-completion-file-name-handler-alist '((file-name-all-completions . tramp-completion-handle-file-name-all-completions) @@ -1216,6 +1264,7 @@ If nil, return `tramp-default-port'." (or (tramp-file-name-port vec) (tramp-get-method-parameter vec 'tramp-default-port))) +;; Comparision of file names is performed by `tramp-equal-remote'. (defun tramp-file-name-equal-p (vec1 vec2) "Check, whether VEC1 and VEC2 denote the same `tramp-file-name'." (and (tramp-file-name-p vec1) (tramp-file-name-p vec2) @@ -1249,19 +1298,22 @@ entry does not exist, return nil." ;;;###tramp-autoload (defun tramp-tramp-file-p (name) "Return t if NAME is a string with Tramp file name syntax." - (and (stringp name) + (and tramp-mode (stringp name) ;; No "/:" and "/c:". This is not covered by `tramp-file-name-regexp'. (not (string-match-p (if (memq system-type '(cygwin windows-nt)) "^/[[:alpha:]]?:" "^/:") name)) + ;; Excluded file names. + (or (null tramp-ignored-file-name-regexp) + (not (string-match-p tramp-ignored-file-name-regexp name))) (string-match-p tramp-file-name-regexp name) t)) (defun tramp-find-method (method user host) "Return the right method string to use. This is METHOD, if non-nil. Otherwise, do a lookup in -`tramp-default-method-alist'." +`tramp-default-method-alist' and `tramp-default-method'." (when (and method (or (string-equal method "") (string-equal method tramp-default-method-marker))) @@ -1272,8 +1324,8 @@ This is METHOD, if non-nil. Otherwise, do a lookup in lmethod item) (while choices (setq item (pop choices)) - (when (and (string-match (or (nth 0 item) "") (or host "")) - (string-match (or (nth 1 item) "") (or user ""))) + (when (and (string-match-p (or (nth 0 item) "") (or host "")) + (string-match-p (or (nth 1 item) "") (or user ""))) (setq lmethod (nth 2 item)) (setq choices nil))) lmethod) @@ -1286,15 +1338,15 @@ This is METHOD, if non-nil. Otherwise, do a lookup in (defun tramp-find-user (method user host) "Return the right user string to use. This is USER, if non-nil. Otherwise, do a lookup in -`tramp-default-user-alist'." +`tramp-default-user-alist' and `tramp-default-user'." (let ((result (or user (let ((choices tramp-default-user-alist) luser item) (while choices (setq item (pop choices)) - (when (and (string-match (or (nth 0 item) "") (or method "")) - (string-match (or (nth 1 item) "") (or host ""))) + (when (and (string-match-p (or (nth 0 item) "") (or method "")) + (string-match-p (or (nth 1 item) "") (or host ""))) (setq luser (nth 2 item)) (setq choices nil))) luser) @@ -1306,18 +1358,24 @@ This is USER, if non-nil. Otherwise, do a lookup in (defun tramp-find-host (method user host) "Return the right host string to use. -This is HOST, if non-nil. Otherwise, it is `tramp-default-host'." - (or (and (> (length host) 0) host) - (let ((choices tramp-default-host-alist) - lhost item) - (while choices - (setq item (pop choices)) - (when (and (string-match (or (nth 0 item) "") (or method "")) - (string-match (or (nth 1 item) "") (or user ""))) - (setq lhost (nth 2 item)) - (setq choices nil))) - lhost) - tramp-default-host)) +This is HOST, if non-nil. Otherwise, do a lookup in +`tramp-default-host-alist' and `tramp-default-host'." + (let ((result + (or (and (> (length host) 0) host) + (let ((choices tramp-default-host-alist) + lhost item) + (while choices + (setq item (pop choices)) + (when (and (string-match-p (or (nth 0 item) "") (or method "")) + (string-match-p (or (nth 1 item) "") (or user ""))) + (setq lhost (nth 2 item)) + (setq choices nil))) + lhost) + tramp-default-host))) + ;; We must mark, whether a default value has been used. + (if (or (> (length host) 0) (null result)) + result + (propertize result 'tramp-default t)))) (defun tramp-dissect-file-name (name &optional nodefault) "Return a `tramp-file-name' structure of NAME, a remote file name. @@ -1329,7 +1387,7 @@ to their default values. For the other file name parts, no default values are used." (save-match-data (unless (tramp-tramp-file-p name) - (tramp-compat-user-error nil "Not a Tramp file name: \"%s\"" name)) + (tramp-user-error nil "Not a Tramp file name: \"%s\"" name)) (if (not (string-match (nth 0 tramp-file-name-structure) name)) (error "`tramp-file-name-structure' didn't match!") (let ((method (match-string (nth 1 tramp-file-name-structure) name)) @@ -1337,7 +1395,7 @@ default values are used." (host (match-string (nth 3 tramp-file-name-structure) name)) (localname (match-string (nth 4 tramp-file-name-structure) name)) (hop (match-string (nth 5 tramp-file-name-structure) name)) - domain port) + domain port v) (when user (when (string-match tramp-user-with-domain-regexp user) (setq domain (match-string 2 user) @@ -1353,13 +1411,50 @@ default values are used." (setq host (replace-match "" nil t host)))) (unless nodefault - (setq method (tramp-find-method method user host) - user (tramp-find-user method user host) - host (tramp-find-host method user host))) - - (make-tramp-file-name - :method method :user user :domain domain :host host :port port - :localname (or localname "") :hop hop))))) + (when hop + (setq v (tramp-dissect-hop-name hop) + hop (and hop (tramp-make-tramp-hop-name v)))) + (let ((tramp-default-host + (or (and v (not (string-match-p "%h" (tramp-file-name-host v))) + (tramp-file-name-host v)) + tramp-default-host))) + (setq method (tramp-find-method method user host) + user (tramp-find-user method user host) + host (tramp-find-host method user host) + hop + (and hop + (format-spec hop (format-spec-make ?h host ?u user)))))) + + ;; Return result. + (prog1 + (setq v (make-tramp-file-name + :method method :user user :domain domain :host host + :port port :localname localname :hop hop)) + ;; Only some methods from tramp-sh.el do support multi-hops. + (when (and + hop + (or (not (tramp-get-method-parameter v 'tramp-login-program)) + (tramp-get-method-parameter v 'tramp-copy-program))) + (tramp-user-error + v "Method `%s' is not supported for multi-hops." method))))))) + +(defun tramp-dissect-hop-name (name &optional nodefault) + "Return a `tramp-file-name' structure of `hop' part of NAME. +See `tramp-dissect-file-name' for details." + (let ((v (tramp-dissect-file-name + (concat tramp-prefix-format + (replace-regexp-in-string + (concat tramp-postfix-hop-regexp "$") + tramp-postfix-host-format name)) + nodefault))) + ;; Only some methods from tramp-sh.el do support multi-hops. + (when (or (not (tramp-get-method-parameter v 'tramp-login-program)) + (tramp-get-method-parameter v 'tramp-copy-program)) + (tramp-user-error + v "Method `%s' is not supported for multi-hops." + (tramp-file-name-method v))) + ;; Return result. + v)) (defun tramp-buffer-name (vec) "A name for the connection buffer VEC." @@ -1370,33 +1465,75 @@ default values are used." (format "*tramp/%s %s@%s*" method user-domain host-port) (format "*tramp/%s %s*" method host-port)))) -(defun tramp-make-tramp-file-name - (method user domain host port localname &optional hop) - "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME. -When not nil, optional DOMAIN, PORT and HOP are used." - ;; Unless `tramp-syntax' is `simplified', we need a method. - (when (and (not (zerop (length tramp-postfix-method-format))) - (zerop (length method))) - (signal 'wrong-type-argument (list 'stringp method))) - (concat tramp-prefix-format hop - (unless (zerop (length tramp-postfix-method-format)) - (concat method tramp-postfix-method-format)) - user - (unless (zerop (length domain)) - (concat tramp-prefix-domain-format domain)) - (unless (zerop (length user)) - tramp-postfix-user-format) - (when host - (if (string-match tramp-ipv6-regexp host) - (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) - host)) - (unless (zerop (length port)) - (concat tramp-prefix-port-format port)) - tramp-postfix-host-format - (when localname localname))) +(defun tramp-make-tramp-file-name (&rest args) + "Construct a Tramp file name from ARGS. + +ARGS could have two different signatures. The first one is of +type (VEC &optional LOCALNAME HOP). +If LOCALNAME is nil, the value in VEC is used. If it is a +symbol, a null localname will be used. Otherwise, LOCALNAME is +expected to be a string, which will be used. +If HOP is nil, the value in VEC is used. If it is a symbol, a +null hop will be used. Otherwise, HOP is expected to be a +string, which will be used. + +The other signature exists for backward compatibility. It has +the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." + (let (method user domain host port localname hop) + (cond + ((tramp-file-name-p (car args)) + (setq method (tramp-file-name-method (car args)) + user (tramp-file-name-user (car args)) + domain (tramp-file-name-domain (car args)) + host (tramp-file-name-host (car args)) + port (tramp-file-name-port (car args)) + localname (tramp-file-name-localname (car args)) + hop (tramp-file-name-hop (car args))) + (when (cadr args) + (setq localname (and (stringp (cadr args)) (cadr args)))) + (when (cl-caddr args) + (setq hop (and (stringp (cl-caddr args)) (cl-caddr args))))) + + (t (setq method (nth 0 args) + user (nth 1 args) + domain (nth 2 args) + host (nth 3 args) + port (nth 4 args) + localname (nth 5 args) + hop (nth 6 args)))) + + ;; Unless `tramp-syntax' is `simplified', we need a method. + (when (and (not (zerop (length tramp-postfix-method-format))) + (zerop (length method))) + (signal 'wrong-type-argument (list 'stringp method))) + (concat tramp-prefix-format hop + (unless (zerop (length tramp-postfix-method-format)) + (concat method tramp-postfix-method-format)) + user + (unless (zerop (length domain)) + (concat tramp-prefix-domain-format domain)) + (unless (zerop (length user)) + tramp-postfix-user-format) + (when host + (if (string-match-p tramp-ipv6-regexp host) + (concat + tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) + host)) + (unless (zerop (length port)) + (concat tramp-prefix-port-format port)) + tramp-postfix-host-format + localname))) + +(defun tramp-make-tramp-hop-name (vec) + "Construct a Tramp hop name from VEC." + (replace-regexp-in-string + tramp-prefix-regexp "" + (replace-regexp-in-string + (concat tramp-postfix-host-regexp "$") tramp-postfix-hop-format + (tramp-make-tramp-file-name vec 'noloc)))) (defun tramp-completion-make-tramp-file-name (method user host localname) - "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME. + "Construct a Tramp file name from METHOD, USER, HOST and LOCALNAME. It must not be a complete Tramp file name, but as long as there are necessary only. This function will be used in file name completion." (concat tramp-prefix-format @@ -1407,7 +1544,7 @@ necessary only. This function will be used in file name completion." (concat user tramp-postfix-user-format)) (unless (zerop (length host)) (concat - (if (string-match tramp-ipv6-regexp host) + (if (string-match-p tramp-ipv6-regexp host) (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) host) @@ -1423,15 +1560,8 @@ necessary only. This function will be used in file name completion." (tramp-set-connection-property vec "process-buffer" (tramp-get-connection-property vec "process-buffer" nil)) - (setq buffer-undo-list t) - (setq default-directory - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - "/")) + (setq buffer-undo-list t + default-directory (tramp-make-tramp-file-name vec 'noloc 'nohop)) (current-buffer)))) (defun tramp-get-connection-buffer (vec) @@ -1517,7 +1647,9 @@ The outline level is equal to the verbosity of the Tramp message." (outline-regexp tramp-debug-outline-regexp)) (outline-mode)) (set (make-local-variable 'outline-regexp) tramp-debug-outline-regexp) - (set (make-local-variable 'outline-level) 'tramp-debug-outline-level)) + (set (make-local-variable 'outline-level) 'tramp-debug-outline-level) + ;; Do not edit the debug buffer. + (use-local-map special-mode-map)) (current-buffer))) (defsubst tramp-debug-message (vec fmt-string &rest arguments) @@ -1533,10 +1665,13 @@ ARGUMENTS to actually emit the message (if applicable)." ";; Emacs: %s Tramp: %s -*- mode: outline; -*-" emacs-version tramp-version)) (when (>= tramp-verbose 10) - (insert - (format - "\n;; Location: %s Git: %s" - (locate-library "tramp") (tramp-repository-get-version))))) + (let ((tramp-verbose 0)) + (insert + (format + "\n;; Location: %s Git: %s/%s" + (locate-library "tramp") + (or tramp-repository-branch "") + (or tramp-repository-version "")))))) (unless (bolp) (insert "\n")) ;; Timestamp. @@ -1554,22 +1689,23 @@ ARGUMENTS to actually emit the message (if applicable)." (setq fn (symbol-name btf)) (unless (and - (string-match "^tramp" fn) + (string-match-p "^tramp" fn) (not - (string-match - (concat - "^" - (regexp-opt - '("tramp-backtrace" - "tramp-compat-funcall" - "tramp-compat-user-error" - "tramp-condition-case-unless-debug" - "tramp-debug-message" - "tramp-error" - "tramp-error-with-buffer" - "tramp-message") - t) - "$") + (string-match-p + (eval-when-compile + (concat + "^" + (regexp-opt + '("tramp-backtrace" + "tramp-compat-funcall" + "tramp-condition-case-unless-debug" + "tramp-debug-message" + "tramp-error" + "tramp-error-with-buffer" + "tramp-message" + "tramp-user-error") + t) + "$")) fn))) (setq fn nil))) (setq btn (1+ btn)))) @@ -1607,47 +1743,47 @@ control string and the remaining ARGUMENTS to actually emit the message (if applicable)." (ignore-errors (when (<= level tramp-verbose) - ;; Match data must be preserved! - (save-match-data - ;; Display only when there is a minimum level. - (when (and tramp-message-show-message (<= level 3)) - (apply 'message - (concat - (cond - ((= level 0) "") - ((= level 1) "") - ((= level 2) "Warning: ") - (t "Tramp: ")) - fmt-string) - arguments)) - ;; Log only when there is a minimum level. - (when (>= tramp-verbose 4) - ;; Translate proc to vec. - (when (processp vec-or-proc) - (let ((tramp-verbose 0)) - (setq vec-or-proc - (tramp-get-connection-property vec-or-proc "vector" nil)))) + ;; Display only when there is a minimum level. + (when (and tramp-message-show-message (<= level 3)) + (apply 'message + (concat + (cond + ((= level 0) "") + ((= level 1) "") + ((= level 2) "Warning: ") + (t "Tramp: ")) + fmt-string) + arguments)) + ;; Log only when there is a minimum level. + (when (>= tramp-verbose 4) + (let ((tramp-verbose 0)) ;; Append connection buffer for error messages. (when (= level 1) - (let ((tramp-verbose 0)) - (with-current-buffer (tramp-get-connection-buffer vec-or-proc) - (setq fmt-string (concat fmt-string "\n%s") - arguments (append arguments (list (buffer-string))))))) - ;; Do it. - (when (tramp-file-name-p vec-or-proc) - (apply 'tramp-debug-message - vec-or-proc - (concat (format "(%d) # " level) fmt-string) - arguments))))))) + (with-current-buffer + (if (processp vec-or-proc) + (process-buffer vec-or-proc) + (tramp-get-connection-buffer vec-or-proc)) + (setq fmt-string (concat fmt-string "\n%s") + arguments (append arguments (list (buffer-string)))))) + ;; Translate proc to vec. + (when (processp vec-or-proc) + (setq vec-or-proc (process-get vec-or-proc 'vector)))) + ;; Do it. + (when (tramp-file-name-p vec-or-proc) + (apply 'tramp-debug-message + vec-or-proc + (concat (format "(%d) # " level) fmt-string) + arguments)))))) (defsubst tramp-backtrace (&optional vec-or-proc) "Dump a backtrace into the debug buffer. If VEC-OR-PROC is nil, the buffer *debug tramp* is used. This function is meant for debugging purposes." - (if vec-or-proc - (tramp-message vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))) - (if (>= tramp-verbose 10) - (with-output-to-temp-buffer "*debug tramp*" (backtrace))))) + (when (>= tramp-verbose 10) + (if vec-or-proc + (tramp-message + vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))) + (with-output-to-temp-buffer "*debug tramp*" (backtrace))))) (defsubst tramp-error (vec-or-proc signal fmt-string &rest arguments) "Emit an error. @@ -1706,6 +1842,31 @@ an input event arrives. The other arguments are passed to `tramp-error'." (when (tramp-file-name-equal-p vec (car tramp-current-connection)) (setcdr tramp-current-connection (current-time))))))) +;; We must make it a defun, because it is used earlier already. +(defun tramp-user-error (vec-or-proc fmt-string &rest arguments) + "Signal a pilot error." + (unwind-protect + (apply + 'tramp-error vec-or-proc + ;; `user-error' has appeared in Emacs 24.3. + (if (fboundp 'user-error) 'user-error 'error) fmt-string arguments) + ;; Save exit. + (when (and tramp-message-show-message + (not (zerop tramp-verbose)) + ;; Do not show when flagged from outside. + (not (tramp-completion-mode-p)) + ;; Show only when Emacs has started already. + (current-message)) + (let ((enable-recursive-minibuffers t)) + ;; `tramp-error' does not show messages. So we must do it ourselves. + (apply 'message fmt-string arguments) + (discard-input) + (sit-for 30) + ;; Reset timestamp. It would be wrong after waiting for a while. + (when + (tramp-file-name-equal-p vec-or-proc (car tramp-current-connection)) + (setcdr tramp-current-connection (current-time))))))) + (defmacro tramp-with-demoted-errors (vec-or-proc format &rest body) "Execute BODY while redirecting the error message to `tramp-message'. BODY is executed like wrapped by `with-demoted-errors'. FORMAT @@ -1756,7 +1917,7 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', "Report progress of an operation for Tramp." (let* ((parameters (cdr reporter)) (message (aref parameters 3))) - (when (string-match message (or (current-message) "")) + (when (string-match-p message (or (current-message) "")) (progress-reporter-update reporter value)))) (defmacro with-tramp-progress-reporter (vec level message &rest body) @@ -1851,7 +2012,6 @@ Example: \"ssh\" \\='((tramp-parse-sconfig \"/etc/ssh_config\") (tramp-parse-sconfig \"~/.ssh/config\")))" - (let ((r function-list) (v function-list)) (setq tramp-completion-function-alist @@ -1866,13 +2026,13 @@ Example: (unless (and (functionp (nth 0 (car v))) (cond ;; Windows registry. - ((string-match "^HKEY_CURRENT_USER" (nth 1 (car v))) + ((string-match-p "^HKEY_CURRENT_USER" (nth 1 (car v))) (and (memq system-type '(cygwin windows-nt)) (zerop (tramp-call-process v "reg" nil nil nil "query" (nth 1 (car v)))))) ;; Zeroconf service type. - ((string-match + ((string-match-p "^_[[:alpha:]]+\\._[[:alpha:]]+$" (nth 1 (car v)))) ;; Configuration file. (t (file-exists-p (nth 1 (car v)))))) @@ -1889,6 +2049,8 @@ For definition of that list see `tramp-set-completion-function'." (append `(;; Default settings are taken into account. (tramp-parse-default-user-host ,method) + ;; Hits from auth-sources. + (tramp-parse-auth-sources ,method) ;; Hosts visited once shall be remembered. (tramp-parse-connection-properties ,method)) ;; The method related defaults. @@ -1947,7 +2109,7 @@ been set up by `rfn-eshadow-setup-minibuffer'." (save-excursion (save-restriction (narrow-to-region - (1+ (or (string-match + (1+ (or (string-match-p (tramp-rfn-eshadow-update-overlay-regexp) (buffer-string) end) end)) @@ -2015,7 +2177,7 @@ expression, which matches more than the file name suffix, the coding system might not be determined. This function repairs it." (let (result) (dolist (elt file-coding-system-alist (nreverse result)) - (when (and (consp elt) (string-match (car elt) filename)) + (when (and (consp elt) (string-match-p (car elt) filename)) ;; We found a matching entry in `file-coding-system-alist'. ;; So we add a similar entry, but with the temporary file name ;; as regexp. @@ -2029,6 +2191,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 . @@ -2062,7 +2225,7 @@ ARGS are the arguments OPERATION has been called with." file-ownership-preserved-p file-readable-p file-regular-p file-remote-p file-selinux-context file-symlink-p file-truename file-writable-p - find-backup-file-name find-file-noselect get-file-buffer + find-backup-file-name get-file-buffer insert-directory insert-file-contents load make-directory make-directory-internal set-file-acl set-file-modes set-file-selinux-context set-file-times @@ -2077,7 +2240,7 @@ ARGS are the arguments OPERATION has been called with." default-directory)) ;; FILE DIRECTORY resp FILE1 FILE2. ((member operation - '(add-name-to-file copy-directory copy-file expand-file-name + '(add-name-to-file copy-directory copy-file file-equal-p file-in-directory-p file-name-all-completions file-name-completion ;; Starting with Emacs 26.1, just the 2nd argument of @@ -2086,11 +2249,16 @@ ARGS are the arguments OPERATION has been called with." ;; file name to be checked. Handled properly in ;; `tramp-handle-*-make-symbolic-link'. file-newer-than-file-p make-symbolic-link rename-file)) - (save-match-data - (cond - ((tramp-tramp-file-p (nth 0 args)) (nth 0 args)) - ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) - (t default-directory)))) + (cond + ((tramp-tramp-file-p (nth 0 args)) (nth 0 args)) + ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) + (t default-directory))) + ;; FILE DIRECTORY resp FILE1 FILE2. + ((eq operation 'expand-file-name) + (cond + ((file-name-absolute-p (nth 0 args)) (nth 0 args)) + ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) + (t default-directory))) ;; START END FILE. ((eq operation 'write-region) (if (file-name-absolute-p (nth 2 args)) @@ -2106,7 +2274,9 @@ ARGS are the arguments OPERATION has been called with." ((member operation '(process-file shell-command start-file-process ;; Emacs 26+ only. - make-nearby-temp-file temporary-file-directory)) + make-nearby-temp-file temporary-file-directory + ;; Emacs 27+ only. + exec-path)) default-directory) ;; PROC. ((member operation @@ -2173,7 +2343,7 @@ preventing reentrant calls of Tramp.") "Invoke Tramp file name handler. Falls back to normal file name handler if no Tramp file name handler exists." (let ((filename (apply 'tramp-file-name-for-operation operation args))) - (if (and tramp-mode (tramp-tramp-file-p filename)) + (if (tramp-tramp-file-p filename) (save-match-data (setq filename (tramp-replace-environment-variables filename)) (with-parsed-tramp-file-name filename nil @@ -2192,8 +2362,11 @@ Falls back to normal file name handler if no Tramp file name handler exists." ;; Tramp packages locally. (when (autoloadp sf) (let ((default-directory - (tramp-compat-temporary-file-directory))) + (tramp-compat-temporary-file-directory)) + file-name-handler-alist) (load (cadr sf) 'noerror 'nomessage))) +;; (tramp-message +;; v 4 "Running `%s'..." (cons operation args)) ;; If `non-essential' is non-nil, Tramp shall ;; not open a new connection. ;; If Tramp detects that it shouldn't continue @@ -2217,6 +2390,8 @@ Falls back to normal file name handler if no Tramp file name handler exists." (let ((tramp-locker t)) (apply foreign operation args)) (setq tramp-locked tl)))))) +;; (tramp-message +;; v 4 "Running `%s'...`%s'" (cons operation args) result) (cond ((eq result 'non-essential) (tramp-message @@ -2238,7 +2413,7 @@ Falls back to normal file name handler if no Tramp file name handler exists." (tramp-message v 1 "Interrupt received in operation %s" (cons operation args))) - ;; Propagate the quit signal. + ;; Propagate the signal. (signal (car err) (cdr err))) ;; When we are in completion mode, some failed @@ -2282,10 +2457,10 @@ Falls back to normal file name handler if no Tramp file name handler exists." ;;;###autoload (progn (defun tramp-autoload-file-name-handler (operation &rest args) "Load Tramp file name handler, and perform OPERATION." + (tramp-unload-file-name-handlers) (if tramp-mode (let ((default-directory temporary-file-directory)) - (load "tramp" 'noerror 'nomessage)) - (tramp-unload-file-name-handlers)) + (load "tramp" 'noerror 'nomessage))) (apply operation args))) ;; `tramp-autoload-file-name-handler' must be registered before @@ -2319,7 +2494,7 @@ remote file names." (lambda (atom) (when (and (functionp atom) (autoloadp (symbol-function atom)) - (string-match files-regexp (cadr (symbol-function atom)))) + (string-match-p files-regexp (cadr (symbol-function atom)))) (ignore-errors (setf (cadr (symbol-function atom)) (expand-file-name (cadr (symbol-function atom)) dir)))))))) @@ -2330,14 +2505,11 @@ remote file names." "Add Tramp file name handlers to `file-name-handler-alist'." ;; Remove autoloaded handlers from file name handler alist. Useful, ;; if `tramp-syntax' has been changed. - (dolist (fnh '(tramp-file-name-handler - tramp-completion-file-name-handler - tramp-autoload-file-name-handler)) - (let ((a1 (rassq fnh file-name-handler-alist))) - (setq file-name-handler-alist (delq a1 file-name-handler-alist)))) + (tramp-unload-file-name-handlers) ;; Add the handlers. We do not add anything to the `operations' - ;; property of `tramp-file-name-handler', this shall be done by the + ;; property of `tramp-file-name-handler' and + ;; `tramp-archive-file-name-handler', this shall be done by the ;; respective foreign handlers. (add-to-list 'file-name-handler-alist (cons tramp-file-name-regexp 'tramp-file-name-handler)) @@ -2351,6 +2523,12 @@ remote file names." (put 'tramp-completion-file-name-handler 'operations (mapcar 'car tramp-completion-file-name-handler-alist)) + (when (bound-and-true-p tramp-archive-enabled) + (add-to-list 'file-name-handler-alist + (cons tramp-archive-file-name-regexp + 'tramp-archive-file-name-handler)) + (put 'tramp-archive-file-name-handler 'safe-magic t)) + ;; If jka-compr or epa-file are already loaded, move them to the ;; front of `file-name-handler-alist'. (dolist (fnh '(epa-file-handler jka-compr-handler)) @@ -2402,11 +2580,10 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." ;;;###autoload (progn (defun tramp-unload-file-name-handlers () "Unload Tramp file name handlers from `file-name-handler-alist'." - (dolist (fnh '(tramp-file-name-handler - tramp-completion-file-name-handler - tramp-autoload-file-name-handler)) - (let ((a1 (rassq fnh file-name-handler-alist))) - (setq file-name-handler-alist (delq a1 file-name-handler-alist)))))) + (dolist (fnh file-name-handler-alist) + (when (and (symbolp (cdr fnh)) + (string-prefix-p "tramp-" (symbol-name (cdr fnh)))) + (setq file-name-handler-alist (delq fnh file-name-handler-alist)))))) (add-hook 'tramp-unload-hook 'tramp-unload-file-name-handlers) @@ -2442,7 +2619,6 @@ not in completion mode." ;; completions. (defun tramp-completion-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for partial Tramp files." - (let ((fullname (tramp-drop-volume-letter (expand-file-name filename directory))) hop result result1) @@ -2465,7 +2641,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. @@ -2540,7 +2715,6 @@ not in completion mode." (defun tramp-completion-dissect-file-name (name) "Returns a list of `tramp-file-name' structures. They are collected by `tramp-completion-dissect-file-name1'." - (let* ((x-nil "\\|\\(\\)") (tramp-completion-ipv6-regexp (format @@ -2615,7 +2789,6 @@ They are collected by `tramp-completion-dissect-file-name1'." "Returns a `tramp-file-name' structure matching STRUCTURE. The structure consists of remote method, remote user, remote host and localname (filename on remote host)." - (save-match-data (when (string-match (nth 0 structure) name) (make-tramp-file-name @@ -2633,7 +2806,7 @@ remote host and localname (filename on remote host)." (mapcar (lambda (method) (and method - (string-match (concat "^" (regexp-quote partial-method)) method) + (string-match-p (concat "^" (regexp-quote partial-method)) method) (tramp-completion-make-tramp-file-name method nil nil nil))) (mapcar 'car tramp-methods))) @@ -2646,7 +2819,7 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." ((and partial-user partial-host) (if (and host - (string-match (concat "^" (regexp-quote partial-host)) host) + (string-match-p (concat "^" (regexp-quote partial-host)) host) (string-equal partial-user (or user partial-user))) (setq user partial-user) (setq user nil @@ -2655,13 +2828,15 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." (partial-user (setq host nil) (unless - (and user (string-match (concat "^" (regexp-quote partial-user)) user)) + (and user + (string-match-p (concat "^" (regexp-quote partial-user)) user)) (setq user nil))) (partial-host (setq user nil) (unless - (and host (string-match (concat "^" (regexp-quote partial-host)) host)) + (and host + (string-match-p (concat "^" (regexp-quote partial-host)) host)) (setq host nil))) (t (setq user nil @@ -2676,6 +2851,23 @@ This function is added always in `tramp-get-completion-function' for all methods. Resulting data are derived from default settings." `((,(tramp-find-user method nil nil) ,(tramp-find-host method nil nil)))) +(defcustom tramp-completion-use-auth-sources auth-source-do-cache + "Whether to use `auth-source-search' for completion of user and host names. +This could be disturbing, if it requires a password / passphrase, +as for \"~/.authinfo.gpg\"." + :group 'tramp + :version "27.1" + :type 'boolean) + +(defun tramp-parse-auth-sources (method) + "Return a list of (user host) tuples allowed to access for METHOD. +This function is added always in `tramp-get-completion-function' +for all methods. Resulting data are derived from default settings." + (and tramp-completion-use-auth-sources + (mapcar + (lambda (x) `(,(plist-get x :user) ,(plist-get x :host))) + (auth-source-search :port method :max most-positive-fixnum)))) + ;; Generic function. (defun tramp-parse-group (regexp match-level skip-regexp) "Return a (user host) tuple allowed to access. @@ -2835,20 +3027,12 @@ Host is always \"localhost\"." (defun tramp-parse-netrc (filename) "Return a list of (user host) tuples allowed to access. User may be nil." - (tramp-parse-file filename 'tramp-parse-netrc-group)) - -(defun tramp-parse-netrc-group () - "Return a (user host) tuple allowed to access. -User may be nil." - (let ((result) - (regexp - (concat - "^[ \t]*machine[ \t]+" "\\(" tramp-host-regexp "\\)" - "\\([ \t]+login[ \t]+" "\\(" tramp-user-regexp "\\)" "\\)?"))) - (when (re-search-forward regexp (point-at-eol) t) - (setq result (list (match-string 3) (match-string 1)))) - (forward-line 1) - result)) + (require 'netrc) + (mapcar + (lambda (item) + (and (assoc "machine" item) + `(,(cdr (assoc "login" item)) ,(cdr (assoc "machine" item))))) + (netrc-parse filename))) ;;;###tramp-autoload (defun tramp-parse-putty (registry-or-dirname) @@ -2905,8 +3089,8 @@ User is always nil." localname))))) (tramp-error v 'file-already-exists newname) (delete-file newname))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (copy-file filename newname 'ok-if-already-exists 'keep-time 'preserve-uid-gid 'preserve-permissions))) @@ -2932,7 +3116,7 @@ User is always nil." (while temp (setq item (directory-file-name (pop temp))) - (when (or (null match) (string-match match item)) + (when (or (null match) (string-match-p match item)) (push (if full (concat directory item) item) result))) (if nosort result (sort result 'string<))))) @@ -2950,13 +3134,41 @@ User is always nil." "Like `dired-uncache' for Tramp files." (with-parsed-tramp-file-name (if (file-directory-p dir) dir (file-name-directory dir)) nil - (tramp-flush-directory-property v localname))) + (tramp-flush-directory-properties v localname))) + +(defun tramp-handle-expand-file-name (name &optional dir) + "Like `expand-file-name' for Tramp files." + ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". + (setq dir (or dir default-directory "/")) + ;; Unless NAME is absolute, concat DIR and NAME. + (unless (file-name-absolute-p name) + (setq name (concat (file-name-as-directory dir) name))) + ;; If NAME is not a Tramp file, run the real handler. + (if (not (tramp-tramp-file-p name)) + (tramp-run-real-handler 'expand-file-name (list name nil)) + ;; Dissect NAME. + (with-parsed-tramp-file-name name nil + (unless (tramp-run-real-handler 'file-name-absolute-p (list localname)) + (setq localname (concat "/" localname))) + ;; Do normal `expand-file-name' (this does "/./" and "/../"). + ;; `default-directory' is bound, because on Windows there would + ;; be problems with UNC shares or Cygwin mounts. + (let ((default-directory (tramp-compat-temporary-file-directory))) + (tramp-make-tramp-file-name + v (tramp-drop-volume-letter + (tramp-run-real-handler 'expand-file-name (list localname)))))))) (defun tramp-handle-file-accessible-directory-p (filename) "Like `file-accessible-directory-p' for Tramp files." (and (file-directory-p filename) (file-readable-p filename))) +(defun tramp-handle-file-directory-p (filename) + "Like `file-directory-p' for Tramp files." + (eq (tramp-compat-file-attribute-type + (file-attributes (file-truename filename))) + t)) + (defun tramp-handle-file-equal-p (filename1 filename2) "Like `file-equalp-p' for Tramp files." ;; Native `file-equalp-p' calls `file-truename', which requires a @@ -2981,6 +3193,17 @@ User is always nil." (file-remote-p (expand-file-name directory))) (tramp-run-real-handler 'file-in-directory-p (list filename directory)))) +(defun tramp-handle-file-local-copy (filename) + "Like `file-local-copy' for Tramp files." + (with-parsed-tramp-file-name filename nil + (unless (file-exists-p filename) + (tramp-error + v tramp-file-missing + "Cannot make local copy of non-existing file `%s'" filename)) + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) + tmpfile))) + (defun tramp-handle-file-modes (filename) "Like `file-modes' for Tramp files." (let ((truename (or (file-truename filename) filename))) @@ -2997,17 +3220,11 @@ User is always nil." ;; Run the command on the localname portion only unless we are in ;; completion mode. (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-domain v) - (tramp-file-name-host v) - (tramp-file-name-port v) - (if (and (zerop (length (tramp-file-name-localname v))) - (not (tramp-connectable-p file))) - "" - (tramp-run-real-handler - 'file-name-as-directory (list (or (tramp-file-name-localname v) "")))) - (tramp-file-name-hop v)))) + v (or (and (zerop (length (tramp-file-name-localname v))) + (not (tramp-connectable-p file))) + (tramp-run-real-handler + 'file-name-as-directory + (list (tramp-file-name-localname v))))))) (defun tramp-handle-file-name-case-insensitive-p (filename) "Like `file-name-case-insensitive-p' for Tramp files." @@ -3034,8 +3251,8 @@ User is always nil." ;; Check, whether we find an existing file with ;; lower case letters. This avoids us to create a ;; temporary file. - (while (and (string-match - "[a-z]" (file-remote-p candidate 'localname)) + (while (and (string-match-p + "[a-z]" (tramp-compat-file-local-name candidate)) (not (file-exists-p candidate))) (setq candidate (directory-file-name @@ -3045,8 +3262,8 @@ User is always nil." ;; to Emacs 26+ like `file-name-case-insensitive-p', ;; so there is no compatibility problem calling it. (unless - (string-match - "[a-z]" (file-remote-p candidate 'localname)) + (string-match-p + "[a-z]" (tramp-compat-file-local-name candidate)) (setq tmpfile (let ((default-directory (file-name-directory filename))) @@ -3059,17 +3276,13 @@ User is always nil." (file-exists-p (concat (file-remote-p candidate) - (upcase (file-remote-p candidate 'localname)))) + (upcase (tramp-compat-file-local-name candidate)))) ;; Cleanup. (when tmpfile (delete-file tmpfile))))))))))) (defun tramp-handle-file-name-completion (filename directory &optional predicate) "Like `file-name-completion' for Tramp files." - (unless (tramp-tramp-file-p directory) - (error - "tramp-handle-file-name-completion invoked on non-tramp directory `%s'" - directory)) (let (hits-ignored-extensions) (or (try-completion @@ -3079,7 +3292,7 @@ User is always nil." (not (and completion-ignored-extensions - (string-match + (string-match-p (concat (regexp-opt completion-ignored-extensions 'paren) "$") x) ;; We remember the hit. (push x hits-ignored-extensions)))))) @@ -3090,19 +3303,14 @@ User is always nil." "Like `file-name-directory' but aware of Tramp files." ;; Everything except the last filename thing is the directory. We ;; cannot apply `with-parsed-tramp-file-name', because this expands - ;; the remote file name parts. This is a problem when we are in - ;; file name completion. + ;; the remote file name parts. (let ((v (tramp-dissect-file-name file t))) - ;; Run the command on the localname portion only. + ;; Run the command on the localname portion only. If this returns + ;; nil, mark also the localname part of `v' as nil. (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-domain v) - (tramp-file-name-host v) - (tramp-file-name-port v) - (tramp-run-real-handler - 'file-name-directory (list (or (tramp-file-name-localname v) ""))) - (tramp-file-name-hop v)))) + v (or (tramp-run-real-handler + 'file-name-directory (list (tramp-file-name-localname v))) + 'noloc)))) (defun tramp-handle-file-name-nondirectory (file) "Like `file-name-nondirectory' but aware of Tramp files." @@ -3141,13 +3349,13 @@ User is always nil." (and (or (not connected) c) (cond ((eq identification 'method) method) - ;; Domain and port are appended. + ;; Domain and port are appended to user and host, + ;; respectively. ((eq identification 'user) (tramp-file-name-user-domain v)) ((eq identification 'host) (tramp-file-name-host-port v)) ((eq identification 'localname) localname) ((eq identification 'hop) hop) - (t (tramp-make-tramp-file-name - method user domain host port "" hop))))))))) + (t (tramp-make-tramp-file-name v 'noloc))))))))) (defun tramp-handle-file-selinux-context (_filename) "Like `file-selinux-context' for Tramp files." @@ -3174,30 +3382,44 @@ User is always nil." (numchase-limit 20) symlink-target) (with-parsed-tramp-file-name result v1 - (with-tramp-file-property v1 v1-localname "file-truename" - (while (and (setq symlink-target (file-symlink-p result)) - (< numchase numchase-limit)) - (setq numchase (1+ numchase) - result - (with-parsed-tramp-file-name (expand-file-name result) v2 - (tramp-make-tramp-file-name - v2-method v2-user v2-domain v2-host v2-port - (funcall - (if (tramp-compat-file-name-quoted-p v2-localname) - 'tramp-compat-file-name-quote 'identity) - - (if (stringp symlink-target) - (if (file-remote-p symlink-target) - (let (file-name-handler-alist) - (tramp-compat-file-name-quote symlink-target)) - (expand-file-name - symlink-target (file-name-directory v2-localname))) - v2-localname))))) - (when (>= numchase numchase-limit) - (tramp-error - v1 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit))) - (directory-file-name result)))))) + ;; We cache only the localname. + (tramp-make-tramp-file-name + v1 + (with-tramp-file-property v1 v1-localname "file-truename" + (while (and (setq symlink-target (file-symlink-p result)) + (< numchase numchase-limit)) + (setq numchase (1+ numchase) + result + (with-parsed-tramp-file-name (expand-file-name result) v2 + (tramp-make-tramp-file-name + v2 + (funcall + (if (tramp-compat-file-name-quoted-p v2-localname) + 'tramp-compat-file-name-quote 'identity) + + (if (stringp symlink-target) + (if (file-remote-p symlink-target) + (let (file-name-handler-alist) + (tramp-compat-file-name-quote symlink-target)) + (expand-file-name + symlink-target (file-name-directory v2-localname))) + v2-localname)) + 'nohop))) + (when (>= numchase numchase-limit) + (tramp-error + v1 'file-error + "Maximum number (%d) of symlinks exceeded" numchase-limit))) + (tramp-compat-file-local-name (directory-file-name result)))))))) + +(defun tramp-handle-file-writable-p (filename) + "Like `file-writable-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-writable-p" + (if (file-exists-p filename) + (tramp-check-cached-permissions v ?w) + ;; If file doesn't exist, check if directory is writable. + (and (file-directory-p (file-name-directory filename)) + (file-writable-p (file-name-directory filename))))))) (defun tramp-handle-find-backup-file-name (filename) "Like `find-backup-file-name' for Tramp files." @@ -3211,8 +3433,7 @@ User is always nil." (if (and (stringp (cdr x)) (file-name-absolute-p (cdr x)) (not (tramp-tramp-file-p (cdr x)))) - (tramp-make-tramp-file-name - method user domain host port (cdr x) hop) + (tramp-make-tramp-file-name v (cdr x)) (cdr x)))) tramp-backup-directory-alist) backup-directory-alist))) @@ -3235,7 +3456,7 @@ User is always nil." (list filename switches wildcard full-directory-p)) ;; `ls-lisp' always returns full listings. We must remove ;; superfluous parts. - (unless (string-match "l" switches) + (unless (string-match-p "l" switches) (save-excursion (goto-char (point-min)) (while (setq start @@ -3317,7 +3538,7 @@ User is always nil." ((stringp remote-copy) (file-local-copy (tramp-make-tramp-file-name - method user domain host port remote-copy))) + v remote-copy 'nohop))) ((stringp tramp-temp-buffer-file-name) (copy-file filename tramp-temp-buffer-file-name 'ok) @@ -3361,9 +3582,7 @@ User is always nil." (or remote-copy (null tramp-temp-buffer-file-name))) (delete-file local-copy)) (when (stringp remote-copy) - (delete-file - (tramp-make-tramp-file-name - method user domain host port remote-copy))))) + (delete-file (tramp-make-tramp-file-name v remote-copy 'nohop))))) ;; Result. (list (expand-file-name filename) @@ -3381,7 +3600,7 @@ User is always nil." ;; The first condition is always true for absolute file names. ;; Included for safety's sake. (unless (or (file-name-directory file) - (string-match "\\.elc?\\'" file)) + (string-match-p "\\.elc?\\'" file)) (tramp-error v 'file-error "File `%s' does not include a `.el' or `.elc' suffix" file))) @@ -3416,7 +3635,7 @@ support symbolic links." (defun tramp-handle-shell-command (command &optional output-buffer error-buffer) "Like `shell-command' for Tramp files." - (let* ((asynchronous (string-match "[ \t]*&[ \t]*\\'" command)) + (let* ((asynchronous (string-match-p "[ \t]*&[ \t]*\\'" command)) ;; We cannot use `shell-file-name' and `shell-command-switch', ;; they are variables of the local host. (args (append @@ -3456,7 +3675,7 @@ support symbolic links." (when p (if (yes-or-no-p "A command is running. Kill it? ") (ignore-errors (kill-process p)) - (tramp-compat-user-error p "Shell command in progress"))) + (tramp-user-error p "Shell command in progress"))) (if current-buffer-p (progn @@ -3507,17 +3726,28 @@ support symbolic links." ;; First, we must replace environment variables. (setq filename (tramp-replace-environment-variables filename)) (with-parsed-tramp-file-name filename nil - ;; Ignore in LOCALNAME everything before "//" or "/~". - (when (and (stringp localname) (string-match ".+?/\\(/\\|~\\)" localname)) - (setq filename - (concat (file-remote-p filename) - (replace-match "\\1" nil nil localname))) - ;; "/m:h:~" does not work for completion. We use "/m:h:~/". - (when (string-match "~$" filename) - (setq filename (concat filename "/")))) - ;; We do not want to replace environment variables, again. + ;; We do not want to replace environment variables, again. "//" + ;; has a special meaning at the beginning of a file name on + ;; Cygwin and MS-Windows, we must remove it. (let (process-environment) - (tramp-run-real-handler 'substitute-in-file-name (list filename)))))) + ;; Ignore in LOCALNAME everything before "//" or "/~". + (when (stringp localname) + (if (string-match "//\\(/\\|~\\)" localname) + (setq filename + (replace-regexp-in-string + "\\`/+" "/" (substitute-in-file-name localname))) + (setq filename + (concat (file-remote-p filename) + (replace-regexp-in-string + "\\`/+" "/" + ;; We must disable cygwin-mount file name + ;; handlers and alike. + (tramp-run-real-handler + 'substitute-in-file-name (list localname)))))))) + ;; "/m:h:~" does not work for completion. We use "/m:h:~/". + (if (and (stringp localname) (string-equal "~" localname)) + (concat filename "/") + filename)))) (defun tramp-handle-set-visited-file-modtime (&optional time-list) "Like `set-visited-file-modtime' for Tramp files." @@ -3526,13 +3756,11 @@ support symbolic links." (buffer-name))) (unless time-list (let ((remote-file-name-inhibit-cache t)) - ;; '(-1 65535) means file doesn't exists yet. (setq time-list (or (tramp-compat-file-attribute-modification-time (file-attributes (buffer-file-name))) - '(-1 65535))))) - ;; We use '(0 0) as a don't-know value. - (unless (equal time-list '(0 0)) + tramp-time-doesnt-exist)))) + (unless (tramp-compat-time-equal-p time-list tramp-time-dont-know) (tramp-run-real-handler 'set-visited-file-modtime (list time-list)))) (defun tramp-handle-verify-visited-file-modtime (&optional buf) @@ -3551,34 +3779,74 @@ of." (eq (visited-file-modtime) 0) (not (file-remote-p f nil 'connected))) t - (with-parsed-tramp-file-name f nil - (let* ((remote-file-name-inhibit-cache t) - (attr (file-attributes f)) - (modtime (tramp-compat-file-attribute-modification-time attr)) - (mt (visited-file-modtime))) - - (cond - ;; File exists, and has a known modtime. - ((and attr (not (equal modtime '(0 0)))) - (< (abs (tramp-time-diff - modtime - ;; For compatibility, deal with both the old - ;; (HIGH . LOW) and the new (HIGH LOW) return - ;; values of `visited-file-modtime'. - (if (atom (cdr mt)) - (list (car mt) (cdr mt)) - mt))) - 2)) - ;; Modtime has the don't know value. - (attr t) - ;; If file does not exist, say it is not modified if and - ;; only if that agrees with the buffer's record. - (t (equal mt '(-1 65535)))))))))) + (let* ((remote-file-name-inhibit-cache t) + (attr (file-attributes f)) + (modtime (tramp-compat-file-attribute-modification-time attr)) + (mt (visited-file-modtime))) + (cond + ;; File exists, and has a known modtime. + ((and attr + (not (tramp-compat-time-equal-p modtime tramp-time-dont-know))) + (< (abs (tramp-time-diff modtime mt)) 2)) + ;; Modtime has the don't know value. + (attr t) + ;; If file does not exist, say it is not modified if and + ;; only if that agrees with the buffer's record. + (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist)))))))) + +(defun tramp-handle-write-region + (start end filename &optional append visit lockname mustbenew) + "Like `write-region' for Tramp files." + (setq filename (expand-file-name filename)) + (with-parsed-tramp-file-name filename nil + (when (and mustbenew (file-exists-p filename) + (or (eq mustbenew 'excl) + (not + (y-or-n-p + (format "File %s exists; overwrite anyway? " filename))))) + (tramp-error v 'file-already-exists filename)) + + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (when (and append (file-exists-p filename)) + (copy-file filename tmpfile 'ok)) + ;; We say `no-message' here because we don't want the visited file + ;; modtime data to be clobbered from the temp file. We call + ;; `set-visited-file-modtime' ourselves later on. + (tramp-run-real-handler + 'write-region (list start end tmpfile append 'no-message lockname)) + (condition-case nil + (rename-file tmpfile filename 'ok-if-already-exists) + (error + (delete-file tmpfile) + (tramp-error + v 'file-error "Couldn't write region to `%s'" filename)))) + + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + + ;; Set file modification time. + (when (or (eq visit t) (stringp visit)) + (set-visited-file-modtime + (tramp-compat-file-attribute-modification-time + (file-attributes filename)))) + + ;; The end. + (when (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) + (tramp-message v 0 "Wrote %s" filename)) + (run-hooks 'tramp-handle-write-region-hook))) + +;; This is used in tramp-gvfs.el and tramp-sh.el. +(defconst tramp-gio-events + '("attribute-changed" "changed" "changes-done-hint" + "created" "deleted" "moved" "pre-unmount" "unmounted") + "List of events \"gio monitor\" could send.") + +;; This is the default handler. tramp-gvfs.el and tramp-sh.el have +;; their own one. (defun tramp-handle-file-notify-add-watch (filename _flags _callback) "Like `file-notify-add-watch' for Tramp files." - ;; This is the default handler. tramp-gvfs.el and tramp-sh.el have - ;; their own one. (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil (tramp-error @@ -3610,17 +3878,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." @@ -3657,7 +3924,7 @@ Send \"yes\" to remote process on confirmation, abort otherwise. See also `tramp-action-yn'." (save-window-excursion (let ((enable-recursive-minibuffers t)) - (save-match-data (pop-to-buffer (tramp-get-connection-buffer vec))) + (pop-to-buffer (tramp-get-connection-buffer vec)) (unless (yes-or-no-p (match-string 0)) (kill-process proc) (throw 'tramp-action 'permission-denied)) @@ -3671,7 +3938,7 @@ Send \"y\" to remote process on confirmation, abort otherwise. See also `tramp-action-yesno'." (save-window-excursion (let ((enable-recursive-minibuffers t)) - (save-match-data (pop-to-buffer (tramp-get-connection-buffer vec))) + (pop-to-buffer (tramp-get-connection-buffer vec)) (unless (y-or-n-p (match-string 0)) (kill-process proc) (throw 'tramp-action 'permission-denied)) @@ -3744,12 +4011,10 @@ PROC and VEC indicate the remote connection to be used. POS, if set, is the starting point of the region to be deleted in the connection buffer." ;; Enable `auth-source', unless "emacs -Q" has been called. We must - ;; use `tramp-current-*' variables in case we have several hops. + ;; use the "password-vector" property in case we have several hops. (tramp-set-connection-property - (make-tramp-file-name - :method tramp-current-method :user tramp-current-user - :domain tramp-current-domain :host tramp-current-host - :port tramp-current-port) + (tramp-get-connection-property + proc "password-vector" (process-get proc 'vector)) "first-password-request" tramp-cache-read-persistent-data) (save-restriction (with-tramp-progress-reporter @@ -3768,7 +4033,9 @@ connection buffer." (with-current-buffer (tramp-get-connection-buffer vec) (widen) (tramp-message vec 6 "\n%s" (buffer-string))) - (unless (eq exit 'ok) + (if (eq exit 'ok) + (ignore-errors (funcall tramp-password-save-function)) + ;; Not successful. (tramp-clear-passwd vec) (delete-process proc) (tramp-error-with-buffer @@ -3781,9 +4048,10 @@ connection buffer." (tramp-get-connection-buffer vec))) ((eq exit 'process-died) (substitute-command-keys - (concat - "Tramp failed to connect. If this happens repeatedly, try\n" - " `\\[tramp-cleanup-this-connection]'"))) + (eval-when-compile + (concat + "Tramp failed to connect. If this happens repeatedly, try\n" + " `\\[tramp-cleanup-this-connection]'")))) ((eq exit 'timeout) (format-message "Timeout reached, see buffer `%s' for details" @@ -3934,6 +4202,7 @@ If it doesn't exist, generate a new one." (with-tramp-connection-property (tramp-get-connection-process vec) "device" (cons -1 (setq tramp-devices (1+ tramp-devices))))) +;; Comparision of vectors is performed by `tramp-file-name-equal-p'. (defun tramp-equal-remote (file1 file2) "Check, whether the remote parts of FILE1 and FILE2 are identical. The check depends on method, user and host name of the files. If @@ -3943,7 +4212,7 @@ account. Example: - (tramp-equal-remote \"/ssh::/etc\" \"/<your host name>:/home\") + (tramp-equal-remote \"/ssh::/etc\" \"/-:<your host name>:/home\") would yield t. On the other hand, the following check results in nil: @@ -3966,53 +4235,52 @@ would yield t. On the other hand, the following check results in nil: (other-read (aref mode-chars 7)) (other-write (aref mode-chars 8)) (other-execute-or-sticky (aref mode-chars 9))) - (save-match-data - (logior - (cond - ((char-equal owner-read ?r) (string-to-number "00400" 8)) - ((char-equal owner-read ?-) 0) - (t (error "Second char `%c' must be one of `r-'" owner-read))) - (cond - ((char-equal owner-write ?w) (string-to-number "00200" 8)) - ((char-equal owner-write ?-) 0) - (t (error "Third char `%c' must be one of `w-'" owner-write))) - (cond - ((char-equal owner-execute-or-setid ?x) (string-to-number "00100" 8)) - ((char-equal owner-execute-or-setid ?S) (string-to-number "04000" 8)) - ((char-equal owner-execute-or-setid ?s) (string-to-number "04100" 8)) - ((char-equal owner-execute-or-setid ?-) 0) - (t (error "Fourth char `%c' must be one of `xsS-'" - owner-execute-or-setid))) - (cond - ((char-equal group-read ?r) (string-to-number "00040" 8)) - ((char-equal group-read ?-) 0) - (t (error "Fifth char `%c' must be one of `r-'" group-read))) - (cond - ((char-equal group-write ?w) (string-to-number "00020" 8)) - ((char-equal group-write ?-) 0) - (t (error "Sixth char `%c' must be one of `w-'" group-write))) - (cond - ((char-equal group-execute-or-setid ?x) (string-to-number "00010" 8)) - ((char-equal group-execute-or-setid ?S) (string-to-number "02000" 8)) - ((char-equal group-execute-or-setid ?s) (string-to-number "02010" 8)) - ((char-equal group-execute-or-setid ?-) 0) - (t (error "Seventh char `%c' must be one of `xsS-'" - group-execute-or-setid))) - (cond - ((char-equal other-read ?r) (string-to-number "00004" 8)) - ((char-equal other-read ?-) 0) - (t (error "Eighth char `%c' must be one of `r-'" other-read))) - (cond - ((char-equal other-write ?w) (string-to-number "00002" 8)) - ((char-equal other-write ?-) 0) - (t (error "Ninth char `%c' must be one of `w-'" other-write))) - (cond - ((char-equal other-execute-or-sticky ?x) (string-to-number "00001" 8)) - ((char-equal other-execute-or-sticky ?T) (string-to-number "01000" 8)) - ((char-equal other-execute-or-sticky ?t) (string-to-number "01001" 8)) - ((char-equal other-execute-or-sticky ?-) 0) - (t (error "Tenth char `%c' must be one of `xtT-'" - other-execute-or-sticky))))))) + (logior + (cond + ((char-equal owner-read ?r) (string-to-number "00400" 8)) + ((char-equal owner-read ?-) 0) + (t (error "Second char `%c' must be one of `r-'" owner-read))) + (cond + ((char-equal owner-write ?w) (string-to-number "00200" 8)) + ((char-equal owner-write ?-) 0) + (t (error "Third char `%c' must be one of `w-'" owner-write))) + (cond + ((char-equal owner-execute-or-setid ?x) (string-to-number "00100" 8)) + ((char-equal owner-execute-or-setid ?S) (string-to-number "04000" 8)) + ((char-equal owner-execute-or-setid ?s) (string-to-number "04100" 8)) + ((char-equal owner-execute-or-setid ?-) 0) + (t (error "Fourth char `%c' must be one of `xsS-'" + owner-execute-or-setid))) + (cond + ((char-equal group-read ?r) (string-to-number "00040" 8)) + ((char-equal group-read ?-) 0) + (t (error "Fifth char `%c' must be one of `r-'" group-read))) + (cond + ((char-equal group-write ?w) (string-to-number "00020" 8)) + ((char-equal group-write ?-) 0) + (t (error "Sixth char `%c' must be one of `w-'" group-write))) + (cond + ((char-equal group-execute-or-setid ?x) (string-to-number "00010" 8)) + ((char-equal group-execute-or-setid ?S) (string-to-number "02000" 8)) + ((char-equal group-execute-or-setid ?s) (string-to-number "02010" 8)) + ((char-equal group-execute-or-setid ?-) 0) + (t (error "Seventh char `%c' must be one of `xsS-'" + group-execute-or-setid))) + (cond + ((char-equal other-read ?r) (string-to-number "00004" 8)) + ((char-equal other-read ?-) 0) + (t (error "Eighth char `%c' must be one of `r-'" other-read))) + (cond + ((char-equal other-write ?w) (string-to-number "00002" 8)) + ((char-equal other-write ?-) 0) + (t (error "Ninth char `%c' must be one of `w-'" other-write))) + (cond + ((char-equal other-execute-or-sticky ?x) (string-to-number "00001" 8)) + ((char-equal other-execute-or-sticky ?T) (string-to-number "01000" 8)) + ((char-equal other-execute-or-sticky ?t) (string-to-number "01001" 8)) + ((char-equal other-execute-or-sticky ?-) 0) + (t (error "Tenth char `%c' must be one of `xtT-'" + other-execute-or-sticky)))))) (defconst tramp-file-mode-type-map '((0 . "-") ; Normal file (SVID-v2 and XPG2) @@ -4037,13 +4305,13 @@ This is used to map a mode number to a permission string.") (defun tramp-file-mode-from-int (mode) "Turn an integer representing a file mode into an ls(1)-like string." (let ((type (cdr - (assoc (logand (lsh mode -12) 15) tramp-file-mode-type-map))) - (user (logand (lsh mode -6) 7)) - (group (logand (lsh mode -3) 7)) - (other (logand (lsh mode -0) 7)) - (suid (> (logand (lsh mode -9) 4) 0)) - (sgid (> (logand (lsh mode -9) 2) 0)) - (sticky (> (logand (lsh mode -9) 1) 0))) + (assoc (logand (ash mode -12) 15) tramp-file-mode-type-map))) + (user (logand (ash mode -6) 7)) + (group (logand (ash mode -3) 7)) + (other (logand (ash mode -0) 7)) + (suid (> (logand (ash mode -9) 4) 0)) + (sgid (> (logand (ash mode -9) 2) 0)) + (sticky (> (logand (ash mode -9) 1) 0))) (setq user (tramp-file-mode-permissions user suid "s")) (setq group (tramp-file-mode-permissions group sgid "s")) (setq other (tramp-file-mode-permissions other sticky "t")) @@ -4071,10 +4339,14 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-get-local-gid (id-format) "The gid of the local user, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." - ;; `group-gid' has been introduced with Emacs 24.4. - (if (and (fboundp 'group-gid) (equal id-format 'integer)) - (tramp-compat-funcall 'group-gid) - (tramp-compat-file-attribute-group-id (file-attributes "~/" id-format)))) + (cond + ;; `group-gid' has been introduced with Emacs 24.4. + ((and (fboundp 'group-gid) (equal id-format 'integer)) + (tramp-compat-funcall 'group-gid)) + ;; `group-name' has been introduced with Emacs 27.1. + ((and (fboundp 'group-name) (equal id-format 'string)) + (tramp-compat-funcall 'group-name (tramp-compat-funcall 'group-gid))) + ((tramp-compat-file-attribute-group-id (file-attributes "~/" id-format))))) (defun tramp-get-local-locale (&optional vec) "Determine locale, supporting UTF8 if possible. @@ -4089,8 +4361,9 @@ VEC is used for tracing." nil "locale" nil t nil "-a")))) (while candidates (goto-char (point-min)) - (if (string-match (format "^%s\r?$" (regexp-quote (car candidates))) - (buffer-string)) + (if (string-match-p + (format "^%s\r?$" (regexp-quote (car candidates))) + (buffer-string)) (setq locale (car candidates) candidates nil) (setq candidates (cdr candidates)))))) @@ -4119,15 +4392,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)) @@ -4169,12 +4434,13 @@ be granted." ;;;###tramp-autoload (defun tramp-local-host-p (vec) - "Return t if this points to the local host, nil otherwise." + "Return t if this points to the local host, nil otherwise. +This handles also chrooted environments, which are not regarded as local." (let ((host (tramp-file-name-host vec)) (port (tramp-file-name-port vec))) (and - (stringp host) - (string-match tramp-local-host-regexp host) + (stringp tramp-local-host-regexp) (stringp host) + (string-match-p tramp-local-host-regexp host) ;; A port is an indication for an ssh tunnel or alike. (null port) ;; The method shall be applied to one of the shell file name @@ -4184,11 +4450,7 @@ be granted." ;; The local temp directory must be writable for the other user. (file-writable-p (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - host port - (tramp-compat-temporary-file-directory))) + vec (tramp-compat-temporary-file-directory) 'nohop)) ;; On some systems, chown runs only for root. (or (zerop (user-uid)) ;; This is defined in tramp-sh.el. Let's assume this is @@ -4198,16 +4460,11 @@ be granted." (defun tramp-get-remote-tmpdir (vec) "Return directory for temporary files on the remote host identified by VEC." (with-tramp-connection-property vec "tmpdir" - (let ((dir (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp") - (tramp-file-name-hop vec)))) + (let ((dir + (tramp-make-tramp-file-name + vec (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp")))) (or (and (file-directory-p dir) (file-writable-p dir) - (file-remote-p dir 'localname)) + (tramp-compat-file-local-name dir)) (tramp-error vec 'file-error "Directory %s not accessible" dir)) dir))) @@ -4317,16 +4574,11 @@ ALIST is of the form ((FROM . TO) ...)." It always returns a return code. The Lisp error raised when PROGRAM is nil is trapped also, returning 1. Furthermore, traces are written with verbosity of 6." - (let ((default-directory (tramp-compat-temporary-file-directory)) - (v (or vec - (make-tramp-file-name - :method tramp-current-method :user tramp-current-user - :domain tramp-current-domain :host tramp-current-host - :port tramp-current-port))) + (let ((default-directory (tramp-compat-temporary-file-directory)) (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 @@ -4344,8 +4596,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 @@ -4355,15 +4607,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 @@ -4376,11 +4623,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 @@ -4390,19 +4637,26 @@ Consults the auth-source package. Invokes `password-read' if available, `read-passwd' else." (let* ((case-fold-search t) (key (tramp-make-tramp-file-name - tramp-current-method tramp-current-user tramp-current-domain - tramp-current-host tramp-current-port "")) + ;; In tramp-sh.el, we must use "password-vector" due to + ;; multi-hop. + (tramp-get-connection-property + proc "password-vector" (process-get proc 'vector)) + 'noloc 'nohop)) (pw-prompt (or prompt (with-current-buffer (process-buffer proc) (tramp-check-for-regexp proc tramp-password-prompt-regexp) (format "%s for %s " (capitalize (match-string 1)) key)))) + (auth-source-creation-prompts `((secret . ,pw-prompt))) ;; We suspend the timers while reading the password. (stimers (with-timeout-suspend)) auth-info auth-passwd) (unwind-protect (with-parsed-tramp-file-name key nil + (setq tramp-password-save-function nil + user + (or user (tramp-get-connection-property key "login-as" nil))) (prog1 (or ;; See if auth-sources contains something useful. @@ -4411,38 +4665,41 @@ Invokes `password-read' if available, `read-passwd' else." v "first-password-request" nil) ;; Try with Tramp's current method. (setq auth-info - (auth-source-search - :max 1 - (and tramp-current-user :user) - (if tramp-current-domain - (format - "%s%s%s" - tramp-current-user tramp-prefix-domain-format - tramp-current-domain) - tramp-current-user) - :host - (if tramp-current-port - (format - "%s%s%s" - tramp-current-host tramp-prefix-port-format - tramp-current-port) - tramp-current-host) - :port tramp-current-method - :require - (cons - :secret (and tramp-current-user '(:user)))) - auth-passwd (plist-get - (nth 0 auth-info) :secret) - auth-passwd (if (functionp auth-passwd) - (funcall auth-passwd) - auth-passwd)))) + (car + (auth-source-search + :max 1 + (and user :user) + (if domain + (concat + user tramp-prefix-domain-format domain) + user) + :host + (if port + (concat + host tramp-prefix-port-format port) + host) + :port method + :require (cons :secret (and user '(:user))) + :create t)) + tramp-password-save-function + (plist-get auth-info :save-function) + auth-passwd (plist-get auth-info :secret))) + (while (functionp auth-passwd) + (setq auth-passwd (funcall auth-passwd))) + auth-passwd) + ;; Try the password cache. - (let ((password (password-read pw-prompt key))) - (password-cache-add key password) - password) - ;; Else, get the password interactively. + (progn + (setq auth-passwd (password-read pw-prompt key) + tramp-password-save-function + (lambda () (password-cache-add key auth-passwd))) + auth-passwd) + + ;; Else, get the password interactively w/o cache. (read-passwd pw-prompt)) + (tramp-set-connection-property v "first-password-request" nil))) + ;; Reenable the timers. (with-timeout-unsuspend stimers)))) @@ -4450,39 +4707,30 @@ 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 ;; Clear also the passwords of the hops. - (tramp-clear-passwd - (tramp-dissect-file-name - (concat - tramp-prefix-format - (replace-regexp-in-string - (concat tramp-postfix-hop-regexp "$") - tramp-postfix-host-format hop))))) + (tramp-clear-passwd (tramp-dissect-hop-name hop))) (auth-source-forget `(:max 1 ,(and user-domain :user) ,user-domain :host ,host-port :port ,method)) - (password-cache-remove - (tramp-make-tramp-file-name method user domain host port "")))) + (password-cache-remove (tramp-make-tramp-file-name vec 'noloc 'nohop)))) -;; Snarfed code from time-date.el. +;;;###tramp-autoload +(defconst tramp-time-dont-know '(0 0 0 1000) + "An invalid time value, used as \"Don’t know\" value.") -(defconst tramp-half-a-year '(241 17024) -"Evaluated by \"(days-to-time 183)\".") +;;;###tramp-autoload +(defconst tramp-time-doesnt-exist '(-1 65535) + "An invalid time value, used as \"Doesn’t exist\" value.") ;;;###tramp-autoload (defun tramp-time-diff (t1 t2) "Return the difference between the two times, in seconds. T1 and T2 are time values (as returned by `current-time' for example)." - ;; Starting with Emacs 25.1, we could change this to use `time-subtract'. - (float-time (tramp-compat-funcall 'subtract-time t1 t2))) + (float-time (time-subtract t1 t2))) (defun tramp-unquote-shell-quote-argument (s) "Remove quotation prefix \"/:\" from string S, and quote it then for shell." @@ -4547,7 +4795,7 @@ Only works for Bourne-like shells." ;; This is for tramp-sh.el. Other backends do not support this (yet). (tramp-compat-funcall 'tramp-send-command - (tramp-get-connection-property proc "vector" nil) + (process-get proc 'vector) (format "kill -2 %d" pid)) ;; Wait, until the process has disappeared. If it doesn't, ;; fall back to the default implementation. @@ -4572,19 +4820,11 @@ Only works for Bourne-like shells." ;; when `default-directory' points to another host. (defun tramp-eshell-directory-change () "Set `eshell-path-env' to $PATH of the host related to `default-directory'." + ;; Remove last element of `(exec-path)', which is `exec-directory'. + ;; Use `path-separator' as it does eshell. (setq eshell-path-env - (if (tramp-tramp-file-p default-directory) - (with-parsed-tramp-file-name default-directory nil - (mapconcat - 'identity - (or - ;; When `tramp-own-remote-path' is in `tramp-remote-path', - ;; the remote path is only set in the session cache. - (tramp-get-connection-property - (tramp-get-connection-process v) "remote-path" nil) - (tramp-get-connection-property v "remote-path" nil)) - ":")) - (getenv "PATH")))) + (mapconcat + 'identity (butlast (tramp-compat-exec-path)) path-separator))) (eval-after-load "esh-util" '(progn diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 9c1e9cfc2eb..b8684da8cf3 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -7,7 +7,6 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.3.5.26.2 ;; This file is part of GNU Emacs. @@ -26,39 +25,49 @@ ;;; Code: -;; In the Tramp GIT repository, the version number and the bug report -;; address are auto-frobbed from configure.ac, so you should edit that -;; file and run "autoconf && ./configure" to change them. Emacs -;; version check is defined in macro AC_EMACS_INFO of aclocal.m4; -;; should be changed only there. +;; In the Tramp GIT, the version number is auto-frobbed from tramp.el, +;; and the bug report address is auto-frobbed from configure.ac. +;; Emacs version check is defined in macro AC_EMACS_INFO of +;; aclocal.m4; should be changed only there. ;;;###tramp-autoload -(defconst tramp-version "2.3.5.26.2" +(defconst tramp-version "2.4.1-pre" "This version of Tramp.") ;;;###tramp-autoload (defconst tramp-bug-report-address "tramp-devel@gnu.org" "Email address to send bug reports to.") -(defun tramp-repository-get-version () - "Try to return as a string the repository revision of the Tramp sources." - (let ((dir (locate-dominating-file (locate-library "tramp") ".git"))) - (when dir - (with-temp-buffer - (let ((default-directory (file-name-as-directory dir))) - (and (zerop - (ignore-errors - (call-process "git" nil '(t nil) nil "rev-parse" "HEAD"))) - (not (zerop (buffer-size))) - (replace-regexp-in-string "\n" "" (buffer-string)))))))) +(defconst tramp-repository-branch + (ignore-errors + ;; Suppress message from `emacs-repository-get-branch'. We must + ;; also handle out-of-tree builds. + (let ((inhibit-message t) + (dir (or (locate-dominating-file (locate-library "tramp") ".git") + source-directory))) + ;; `emacs-repository-get-branch' has been introduced with Emacs 27.1. + (with-no-warnings + (and (stringp dir) (file-directory-p dir) + (emacs-repository-get-branch dir))))) + "The repository branch of the Tramp sources.") + +(defconst tramp-repository-version + (ignore-errors + ;; Suppress message from `emacs-repository-get-version'. We must + ;; also handle out-of-tree builds. + (let ((inhibit-message t) + (dir (or (locate-dominating-file (locate-library "tramp") ".git") + source-directory))) + (and (stringp dir) (file-directory-p dir) + (emacs-repository-get-version dir)))) + "The repository revision of the Tramp sources.") ;; Check for Emacs version. -(let ((x (if (>= emacs-major-version 24) - "ok" - (format "Tramp 2.3.5.26.2 is not fit for %s" - (when (string-match "^.*$" (emacs-version)) - (match-string 0 (emacs-version))))))) - (unless (string-match "\\`ok\\'" x) (error "%s" x))) +(let ((x (if (not (string-lessp emacs-version "24.1")) + "ok" + (format "Tramp 2.4.1-pre is not fit for %s" + (replace-regexp-in-string "\n" "" (emacs-version)))))) + (unless (string-equal "ok" x) (error "%s" x))) ;; Tramp versions integrated into Emacs. If a user option declares a ;; `:package-version' which doesn't belong to an integrated Tramp diff --git a/lisp/net/zeroconf.el b/lisp/net/zeroconf.el index 351fc9fc305..25a8dea4316 100644 --- a/lisp/net/zeroconf.el +++ b/lisp/net/zeroconf.el @@ -382,6 +382,8 @@ TYPE. The resulting list has the format ;; `zeroconf-services-hash'. (gethash (concat name "/" type) zeroconf-services-hash nil)) +(defvar dbus-debug) + (defun zeroconf-resolve-service (service) "Return all service attributes SERVICE as list. NAME must be a string. The service must be of service type @@ -526,22 +528,27 @@ DOMAIN is nil, the local domain is used." zeroconf-avahi-current-domain zeroconf-avahi-flags-unspec)))) +(defvar zeroconf-service-type-browser-handler-running nil + "Prevent infinite recursion in `zeroconf-service-type-browser-handler'.") + (defun zeroconf-service-type-browser-handler (&rest val) "Registered service type browser handler at the Avahi daemon." - (when zeroconf-debug - (message "zeroconf-service-type-browser-handler: %s %S" - (dbus-event-member-name last-input-event) val)) - (cond - ((string-equal (dbus-event-member-name last-input-event) "ItemNew") - ;; Parameters: (interface protocol type domain flags) - ;; Register a service browser. - (let ((object-path (zeroconf-register-service-browser (nth 2 val)))) - ;; Register the signals. - (dolist (member '("ItemNew" "ItemRemove" "Failure")) - (dbus-register-signal - :system zeroconf-service-avahi object-path - zeroconf-interface-avahi-service-browser member - 'zeroconf-service-browser-handler)))))) + (unless zeroconf-service-type-browser-handler-running + (let ((zeroconf-service-type-browser-handler-running t)) + (when zeroconf-debug + (message "zeroconf-service-type-browser-handler: %s %S" + (dbus-event-member-name last-input-event) val)) + (cond + ((string-equal (dbus-event-member-name last-input-event) "ItemNew") + ;; Parameters: (interface protocol type domain flags) + ;; Register a service browser. + (let ((object-path (zeroconf-register-service-browser (nth 2 val)))) + ;; Register the signals. + (dolist (member '("ItemNew" "ItemRemove" "Failure")) + (dbus-register-signal + :system zeroconf-service-avahi object-path + zeroconf-interface-avahi-service-browser member + 'zeroconf-service-browser-handler)))))))) (defun zeroconf-register-service-browser (type) "Register a service browser at the Avahi daemon." |