Author: Michael Albinus diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index a5919e071c3..ecd298e4525 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -1246,7 +1246,7 @@ tramp-gvfs-handle-expand-file-name (when (string-match (rx bos "/" (+ (not "/")) (group "/.." (? "/"))) localname) (setq localname (replace-match "/" t t localname 1))) - (when (string-match (rx bol "/.." (? "/")) localname) + (when (string-match (rx bos "/.." (? "/")) localname) (setq localname (replace-match "/" t t localname)))) ;; There might be a double slash. Remove this. (while (string-match "//" localname) @@ -1340,8 +1340,8 @@ tramp-gvfs-get-file-attributes (with-parsed-tramp-file-name filename nil (setq localname (file-name-unquote localname)) (if (or (and (string-match-p - (rx bol (| "afp" (: "dav" (? "s")) "smb") eol) method) - (string-match-p (rx bol (? "/") (+ (not "/")) eol) localname)) + (rx bos (| "afp" (: "dav" (? "s")) "smb") eos) method) + (string-match-p (rx bos (? "/") (+ (not "/")) eos) localname)) (string-equal localname "/")) (tramp-gvfs-get-root-attributes filename) (assoc @@ -1375,7 +1375,11 @@ tramp-gvfs-handle-file-attributes (lambda (x) (unibyte-string (string-to-number (match-string 1 x) 16))) res-symlink-target) - 'utf-8))) + 'utf-8)) + ;; If the resulting localname looks remote, we must quote it + ;; for security reasons. + (when (tramp-tramp-file-p res-symlink-target) + (setq res-symlink-target (file-name-quote res-symlink-target 'top)))) ;; ... number links (setq res-numlinks (string-to-number @@ -1768,14 +1772,14 @@ tramp-gvfs-file-name "Retrieve file name from D-Bus OBJECT-PATH." (dbus-unescape-from-identifier (replace-regexp-in-string - (rx bol (* nonl) "/" (group (+ (not "/"))) eol) "\\1" object-path))) + (rx bos (* nonl) "/" (group (+ (not "/"))) eos) "\\1" object-path))) (defun tramp-gvfs-url-host (url) "Return the host name part of URL, a string. We cannot use `url-host', because `url-generic-parse-url' returns a downcased host name only." (and (stringp url) - (string-match (rx bol (+ alnum) "://" (group (+ (not (any "/:"))))) url) + (string-match (rx bos (+ alnum) "://" (group (+ (not (any "/:"))))) url) (match-string 1 url))) ;; This is used in GNU ELPA package tramp-locproc.el. @@ -1929,7 +1933,7 @@ tramp-gvfs-handler-mounted-unmounted (cadr (assoc "ssl" (cadr mount-spec))))) (uri (tramp-gvfs-dbus-byte-array-to-string (cadr (assoc "uri" (cadr mount-spec)))))) - (when (string-match (rx bol (group (| "afp" "smb"))) method) + (when (string-match (rx bos (group (| "afp" "smb"))) method) (setq method (match-string 1 method))) (when (and (string-equal "dav" method) (string-equal "true" ssl)) (setq method "davs")) @@ -2029,7 +2033,7 @@ tramp-gvfs-connection-mounted-p (or (cadr (assoc "share" (cadr mount-spec))) (cadr (assoc "volume" (cadr mount-spec))))))) - (when (string-match (rx bol (group (| "afp" "smb"))) method) + (when (string-match (rx bos (group (| "afp" "smb"))) method) (setq method (match-string 1 method))) (when (and (string-equal "dav" method) (string-equal "true" ssl)) (setq method "davs")) @@ -2062,7 +2066,7 @@ tramp-gvfs-connection-mounted-p (string-equal host (tramp-file-name-host vec)) (string-equal port (tramp-file-name-port vec)) (string-match-p - (rx bol "/" (literal (or share ""))) + (rx bos "/" (literal (or share ""))) (tramp-file-name-unquote-localname vec))) ;; Set mountpoint and location. (tramp-set-file-property vec "/" "fuse-mountpoint" fuse-mountpoint) @@ -2088,7 +2092,7 @@ tramp-gvfs-unmount (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-p (rx bol "(aya{sv})") tramp-gvfs-mountlocation-signature) + (if (string-match-p (rx bos "(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)))) @@ -2107,9 +2111,9 @@ tramp-gvfs-mount-spec (tramp-media-device-port media) (tramp-file-name-port vec))) (localname (tramp-file-name-unquote-localname vec)) (share (when (string-match - (rx bol (? "/") (group (+ (not "/")))) localname) + (rx bos (? "/") (group (+ (not "/")))) localname) (match-string 1 localname))) - (ssl (if (string-match-p (rx bol (| "davs" "nextcloud")) method) + (ssl (if (string-match-p (rx bos (| "davs" "nextcloud")) method) "true" "false")) (mount-spec `(:array @@ -2118,7 +2122,7 @@ tramp-gvfs-mount-spec (list (tramp-gvfs-mount-spec-entry "type" "smb-share") (tramp-gvfs-mount-spec-entry "server" host) (tramp-gvfs-mount-spec-entry "share" share))) - ((string-match-p (rx bol (| "davs" "nextcloud")) method) + ((string-match-p (rx bos (| "davs" "nextcloud")) method) (list (tramp-gvfs-mount-spec-entry "type" "dav") (tramp-gvfs-mount-spec-entry "host" host) (tramp-gvfs-mount-spec-entry "ssl" ssl))) @@ -2132,7 +2136,7 @@ tramp-gvfs-mount-spec ((string-equal "nextcloud" method) (list (tramp-gvfs-mount-spec-entry "type" "owncloud") (tramp-gvfs-mount-spec-entry "host" host))) - ((string-match-p (rx bol "http") method) + ((string-match-p (rx bos "http") method) (list (tramp-gvfs-mount-spec-entry "type" "http") (tramp-gvfs-mount-spec-entry "uri" @@ -2149,8 +2153,8 @@ tramp-gvfs-mount-spec ,@(when port (list (tramp-gvfs-mount-spec-entry "port" port))))) (mount-pref - (if (and (string-match-p (rx bol "dav") method) - (string-match (rx bol (? "/") (+ (not "/"))) localname)) + (if (and (string-match-p (rx bos "dav") method) + (string-match (rx bos (? "/") (+ (not "/"))) localname)) (match-string 0 localname) (tramp-gvfs-get-remote-prefix vec)))) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index cd5c3f46f54..125640560ff 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -192,7 +192,7 @@ tramp-rclone-parse-device-names (with-tramp-connection-property nil "rclone-device-names" (tramp-compat-seq-keep (lambda (line) - (when (string-match (rx bol (group (+ (not blank))) ":" eol) line) + (when (string-match (rx bos (group (+ (not blank))) ":" eos) line) `(nil ,(match-string 1 line)))) (tramp-process-lines nil tramp-rclone-program "listremotes")))) @@ -366,7 +366,7 @@ tramp-rclone-remote-file-name (tramp-rclone-maybe-open-connection v) ;; TODO: This shall be handled by `expand-file-name'. (setq localname - (replace-regexp-in-string (rx bol ".") "" (or localname ""))) + (replace-regexp-in-string (rx bos ".") "" (or localname ""))) (format "%s%s" (tramp-fuse-mounted-p v) localname))) ;; It is a local file name. filename)) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 6f88c7dedba..2ed5f3369a6 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -1657,7 +1657,7 @@ tramp-smb-get-share "Return the share name of LOCALNAME." (save-match-data (let ((localname (tramp-file-name-unquote-localname vec))) - (when (string-match (rx bol (? "/") (group (+ (not "/"))) "/") localname) + (when (string-match (rx bos (? "/") (group (+ (not "/"))) "/") localname) (match-string 1 localname))))) (defun tramp-smb-get-localname (vec &optional share) @@ -1670,7 +1670,7 @@ tramp-smb-get-localname (setq localname (if (string-match - (rx bol (? "/") (+ (not "/")) (group "/" (* nonl))) localname) + (rx bos (? "/") (+ (not "/")) (group "/" (* nonl))) localname) ;; There is a share, separated by "/". (if (not (tramp-smb-get-cifs-capabilities vec)) (mapconcat @@ -1679,7 +1679,7 @@ tramp-smb-get-localname (match-string 1 localname)) ;; There is just a share. (if (string-match - (rx bol (? "/") (group (+ (not "/"))) eol) localname) + (rx bos (? "/") (group (+ (not "/"))) eos) localname) (match-string 1 localname) "")))) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index eb0bc649d69..792887da772 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1024,11 +1024,11 @@ tramp-prefix-format (defun tramp-build-prefix-regexp () "Return `tramp-prefix-regexp'." - (rx bol (literal (tramp-build-prefix-format)))) + (rx bos (literal (tramp-build-prefix-format)))) (defvar tramp-prefix-regexp nil ; Initialized when defining `tramp-syntax'! "Regexp matching the very beginning of Tramp file names. -Should always start with \"^\". Derived from `tramp-prefix-format'.") +Should always start with \"\\\\=`\". Derived from `tramp-prefix-format'.") (defconst tramp-method-regexp-alist `((default . ,(rx (| (literal tramp-default-method-marker) (>= 2 alnum)))) @@ -1070,7 +1070,10 @@ tramp-postfix-method-regexp "Regexp matching delimiter between method and user or host names. Derived from `tramp-postfix-method-format'.") -(defconst tramp-user-regexp (rx (+ (not (any "/:|[]" blank)))) +(defconst tramp-user-regexp + (rx (| (+ (not (any "/\\^$?*:;|[]{}()<>`'\"" blank))) + ;; Environment variable. + (: "$" (+ (any "_" alnum))))) "Regexp matching user names.") (defconst tramp-prefix-domain-format "%" @@ -1845,6 +1848,8 @@ tramp-dissect-file-name (hop (match-string (nth 5 tramp-file-name-structure) name)) domain port v) (when user + (while (string-match (rx bos "$" (group (+ (any "_" alnum))) eos) user) + (setq user (getenv (match-string 1 user)))) (when (string-match tramp-user-with-domain-regexp user) (setq domain (match-string 2 user) user (match-string 1 user)))) @@ -2705,9 +2710,9 @@ tramp-file-name-handler ;; `file-remote-p' is called for everything, even for symbolic ;; links which look remote. We don't want to get an error. (non-essential (or non-essential (eq operation 'file-remote-p)))) + (setq filename (tramp-replace-environment-variables filename)) (if (tramp-tramp-file-p filename) (save-match-data - (setq filename (tramp-replace-environment-variables filename)) (with-parsed-tramp-file-name filename nil (let ((current-connection tramp-current-connection) (foreign @@ -6950,6 +6955,9 @@ tramp-convert-file-attributes (caar attr)) (decode-coding-string (match-string 1 (caar attr)) 'utf-8)))) + ;; Quote remote-like symlink. + (when (and (stringp (car attr)) (tramp-tramp-file-p (car attr))) + (setcar attr (file-name-quote (car attr) 'top))) ;; Set file's gid change bit. (setcar (nthcdr 9 attr)