diff options
Diffstat (limited to 'lisp/net')
55 files changed, 1849 insertions, 1277 deletions
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index 3f3a3df8e55..a6c256eeba8 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -230,7 +230,7 @@ ;; ;; 1. For dired to work on a host which marks symlinks with a trailing @ in ;; an ls -alF listing, you need to (setq dired-ls-F-marks-symlinks t). -;; Most UNIX systems do not do this, but ULTRIX does. If you think that +;; Most UNIX systems do not do this, but ULTRIX does. If you think that ;; there is a chance you might connect to an ULTRIX machine (such as ;; prep.ai.mit.edu), then set this variable accordingly. This will have ;; the side effect that dired will have problems with symlinks whose names @@ -241,34 +241,34 @@ ;; frequently, and ange-ftp seems to be unable to guess its host-type, ;; then setting the appropriate host-type regexp ;; (ange-ftp-vms-host-regexp, ange-ftp-mts-host-regexp, or -;; ange-ftp-cms-host-regexp) accordingly should help. Also, please report +;; ange-ftp-cms-host-regexp) accordingly should help. Also, please report ;; ange-ftp's inability to recognize the host-type as a bug. ;; ;; 3. For slow connections, you might get "listing unreadable" error ;; messages, or get an empty buffer for a file that you know has something -;; in it. The solution is to increase the value of ange-ftp-retry-time. +;; in it. The solution is to increase the value of ange-ftp-retry-time. ;; Its default value is 5 which is plenty for reasonable connections. ;; However, for some transatlantic connections I set this to 20. ;; -;; 4. Beware of compressing files on non-UNIX hosts. Ange-ftp will do it by +;; 4. Beware of compressing files on non-UNIX hosts. Ange-ftp will do it by ;; copying the file to the local machine, compressing it there, and then -;; sending it back. Binary file transfers between machines of different -;; architectures can be a risky business. Test things out first on some -;; test files. See "Bugs" below. Also, note that ange-ftp copies files by -;; moving them through the local machine. Again, be careful when doing +;; sending it back. Binary file transfers between machines of different +;; architectures can be a risky business. Test things out first on some +;; test files. See "Bugs" below. Also, note that ange-ftp copies files by +;; moving them through the local machine. Again, be careful when doing ;; this with binary files on non-Unix machines. ;; ;; 5. Beware that dired over ftp will use your setting of dired-no-confirm ;; (list of dired commands for which confirmation is not asked). You ;; might want to reconsider your setting of this variable, because you ;; might want confirmation for more commands on remote direds than on -;; local direds. For example, I strongly recommend that you not include -;; compress and uncompress in this list. If there is enough demand it +;; local direds. For example, I strongly recommend that you not include +;; compress and uncompress in this list. If there is enough demand it ;; might be a good idea to have an alist ange-ftp-dired-no-confirm of ;; pairs ( TYPE . LIST ), where TYPE is an operating system type and LIST ;; is a list of commands for which confirmation would be suppressed. Then ;; remote dired listings would take their (buffer-local) value of -;; dired-no-confirm from this alist. Who votes for this? +;; dired-no-confirm from this alist. Who votes for this? ;; --------------------------------------------------------------------- ;; Non-UNIX support: @@ -277,7 +277,7 @@ ;; VMS support: ;; ;; Ange-ftp has full support for VMS hosts. It should be able to -;; automatically recognize any VMS machine. However, if it fails to do +;; automatically recognize any VMS machine. However, if it fails to do ;; this, you can use the command ange-ftp-add-vms-host. Also, you can ;; set the variable ange-ftp-vms-host-regexp in your init file. We ;; would be grateful if you would report any failures to automatically @@ -308,46 +308,46 @@ ;; Therefore, to access a VMS file, you must enter the filename with upper ;; case letters. ;; 2. To access the latest version of file under VMS, you use the filename -;; without the ";" and version number. You should always edit the latest -;; version of a file. If you want to edit an earlier version, copy it to a -;; new file first. This has nothing to do with ange-ftp, but is simply -;; good VMS operating practice. Therefore, to edit FILE.TXT;3 (say 3 is -;; latest version), do C-x C-f /ymir.claremont.edu:FILE.TXT. If you +;; without the ";" and version number. You should always edit the latest +;; version of a file. If you want to edit an earlier version, copy it to a +;; new file first. This has nothing to do with ange-ftp, but is simply +;; good VMS operating practice. Therefore, to edit FILE.TXT;3 (say 3 is +;; latest version), do C-x C-f /ymir.claremont.edu:FILE.TXT. If you ;; inadvertently do C-x C-f /ymir.claremont.edu:FILE.TXT;3, you will find ;; that VMS will not allow you to save the file because it will refuse to ;; overwrite FILE.TXT;3, but instead will want to create FILE.TXT;4, and -;; attach the buffer to this file. To get out of this situation, M-x +;; attach the buffer to this file. To get out of this situation, M-x ;; write-file /ymir.claremont.edu:FILE.TXT will attach the buffer to -;; latest version of the file. For this reason, in dired "f" +;; latest version of the file. For this reason, in dired "f" ;; (dired-find-file), always loads the file sans version, whereas "v", -;; (dired-view-file), always loads the explicit version number. The +;; (dired-view-file), always loads the explicit version number. The ;; reasoning being that it reasonable to view old versions of a file, but ;; not to edit them. ;; 3. EMACS has a feature in which it does environment variable substitution -;; in filenames. Therefore, to enter a $ in a filename, you must quote it +;; in filenames. Therefore, to enter a $ in a filename, you must quote it ;; by typing $$. ;; MTS support: ;; ;; Ange-ftp has full support for hosts running ;; the Michigan terminal system. It should be able to automatically -;; recognize any MTS machine. However, if it fails to do this, you can use +;; recognize any MTS machine. However, if it fails to do this, you can use ;; the command ange-ftp-add-mts-host. As well, you can set the variable -;; ange-ftp-mts-host-regexp in your init file. We would be grateful if you +;; ange-ftp-mts-host-regexp in your init file. We would be grateful if you ;; would report any failures to automatically recognize a MTS host as a bug. ;; ;; Filename syntax: ;; -;; MTS filenames are entered in a UNIX-y way. For example, if your account +;; MTS filenames are entered in a UNIX-y way. For example, if your account ;; was YYYY, the file FILE in the account XXXX: on mtsg.ubc.ca would be ;; entered as ;; /YYYY@mtsg.ubc.ca:/XXXX:/FILE -;; In other words, MTS accounts are treated as UNIX directories. Of course, +;; In other words, MTS accounts are treated as UNIX directories. Of course, ;; to access a file in another account, you must have access permission for ;; it. If FILE were in your own account, then you could enter it in a ;; relative name fashion as ;; /YYYY@mtsg.ubc.ca:FILE -;; MTS filenames can be up to 12 characters. Like UNIX, the structure of the +;; MTS filenames can be up to 12 characters. Like UNIX, the structure of the ;; filename does not contain a TYPE (i.e. it can have as many "."'s as you ;; like.) MTS filenames are always in upper case, and hence be sure to enter ;; them as such! MTS is not case sensitive, but an EMACS running under UNIX @@ -359,37 +359,37 @@ ;; CMS. It should be able to automatically recognize any CMS machine. ;; However, if it fails to do this, you can use the command ;; ange-ftp-add-cms-host. As well, you can set the variable -;; ange-ftp-cms-host-regexp in your init file. We would be grateful if you +;; ange-ftp-cms-host-regexp in your init file. We would be grateful if you ;; would report any failures to automatically recognize a CMS host as a bug. ;; ;; Filename syntax: ;; -;; CMS filenames are entered in a UNIX-y way. In other words, minidisks are -;; treated as UNIX directories. For example to access the file READ.ME in +;; CMS filenames are entered in a UNIX-y way. In other words, minidisks are +;; treated as UNIX directories. For example to access the file READ.ME in ;; minidisk *.311 on cuvmb.cc.columbia.edu, you would enter ;; /anonymous@cuvmb.cc.columbia.edu:/*.311/READ.ME ;; If *.301 is the default minidisk for this account, you could access ;; FOO.BAR on this minidisk as ;; /anonymous@cuvmb.cc.columbia.edu:FOO.BAR ;; CMS filenames are of the form FILE.TYPE, where both FILE and TYPE can be -;; up to 8 characters. Again, beware that CMS filenames are always upper +;; up to 8 characters. Again, beware that CMS filenames are always upper ;; case, and hence must be entered as such. ;; ;; Tips: ;; 1. CMS machines, with the exception of anonymous accounts, nearly always -;; need an account password. To have ange-ftp send an account password, +;; need an account password. To have ange-ftp send an account password, ;; you can either include it in your .netrc file, or use ;; ange-ftp-set-account. -;; 2. Ange-ftp cannot send "write passwords" for a minidisk. Hopefully, we +;; 2. Ange-ftp cannot send "write passwords" for a minidisk. Hopefully, we ;; can fix this. ;; ;; BS2000 support: ;; ;; Ange-ftp has full support for BS2000 hosts. It should be able to -;; automatically recognize any BS2000 machine. However, if it fails to +;; automatically recognize any BS2000 machine. However, if it fails to ;; do this, you can use the command ange-ftp-add-bs2000-host. As well, ;; you can set the variable ange-ftp-bs2000-host-regexp in your .emacs -;; file. We would be grateful if you would report any failures to auto- +;; file. We would be grateful if you would report any failures to auto- ;; matically recognize a BS2000 host as a bug. ;; ;; If you want to access the POSIX subsystem on BS2000 you MUST use @@ -436,10 +436,10 @@ ;; Therefore, to access a BS2000 file, you must enter the filename with ;; upper case letters. ;; 2. EMACS has a feature in which it does environment variable substitution -;; in filenames. Therefore, to enter a $ in a filename, you must quote it +;; in filenames. Therefore, to enter a $ in a filename, you must quote it ;; by typing $$. ;; 3. BS2000 machines, with the exception of anonymous accounts, nearly -;; always need an account password. To have ange-ftp send an account +;; always need an account password. To have ange-ftp send an account ;; password, you can either include it in your .netrc file, or use ;; ange-ftp-set-account. ;; @@ -457,15 +457,15 @@ ;; ;; 2. Some combinations of FTP clients and servers break and get out of sync ;; when asked to list a non-existent directory. Some of the ai.mit.edu -;; machines cause this problem for some FTP clients. Using +;; machines cause this problem for some FTP clients. Using ;; ange-ftp-kill-ftp-process can restart the ftp process, which ;; should get things back in sync. ;; ;; 3. Ange-ftp does not check to make sure that when creating a new file, ;; you provide a valid filename for the remote operating system. ;; If you do not, then the remote FTP server will most likely -;; translate your filename in some way. This may cause ange-ftp to -;; get confused about what exactly is the name of the file. The +;; translate your filename in some way. This may cause ange-ftp to +;; get confused about what exactly is the name of the file. The ;; most common causes of this are using lower case filenames on systems ;; which support only upper case, and using filenames which are too ;; long. @@ -479,39 +479,39 @@ ;; disgusting way around this problem is to talk to the FTP process via ;; rlogin which does the 'right' things with pty's. ;; -;; 6. For CMS support, we send too many cd's. Since cd's are cheap, I haven't -;; worried about this too much. Eventually, we should have some caching +;; 6. For CMS support, we send too many cd's. Since cd's are cheap, I haven't +;; worried about this too much. Eventually, we should have some caching ;; of the current minidisk. ;; ;; 7. Some CMS machines do not assign a default minidisk when you ftp them as -;; anonymous. It is then necessary to guess a valid minidisk name, and cd -;; to it. This is (understandably) beyond ange-ftp. +;; anonymous. It is then necessary to guess a valid minidisk name, and cd +;; to it. This is (understandably) beyond ange-ftp. ;; ;; 8. Remote to remote copying of files on non-Unix machines can be risky. ;; Depending on the variable ange-ftp-binary-file-name-regexp, ange-ftp -;; will use binary mode for the copy. Between systems of different +;; will use binary mode for the copy. Between systems of different ;; architecture, this still may not be enough to guarantee the integrity -;; of binary files. Binary file transfers from VMS machines are -;; particularly problematical. Should ange-ftp-binary-file-name-regexp be +;; of binary files. Binary file transfers from VMS machines are +;; particularly problematical. Should ange-ftp-binary-file-name-regexp be ;; an alist of OS type, regexp pairs? ;; ;; 9. The code to do compression of files over ftp is not as careful as it -;; should be. It deletes the old remote version of the file, before +;; should be. It deletes the old remote version of the file, before ;; actually checking if the local to remote transfer of the compressed -;; file succeeds. Of course to delete the original version of the file +;; file succeeds. Of course to delete the original version of the file ;; after transferring the compressed version back is also dangerous, ;; because some OS's have severe restrictions on the length of filenames, ;; and when the compressed version is copied back the "-Z" or ".Z" may be -;; truncated. Then, ange-ftp would delete the only remaining version of +;; truncated. Then, ange-ftp would delete the only remaining version of ;; the file. Maybe ange-ftp should make backups when it compresses files ;; (of course, the backup "~" could also be truncated off, sigh...). ;; Suggestions? ;; ;; 10. If a dir listing is attempted for an empty directory on (at least -;; some) VMS hosts, an ftp error is given. This is really an ftp bug, and +;; some) VMS hosts, an ftp error is given. This is really an ftp bug, and ;; I don't know how to get ange-ftp work to around it. ;; -;; 11. Bombs on filenames that start with a space. Deals well with filenames +;; 11. Bombs on filenames that start with a space. Deals well with filenames ;; containing spaces, but beware that the remote ftpd may not like them ;; much. ;; @@ -519,13 +519,13 @@ ;; It needs to be reimplemented by modifying the parse-...-listing ;; functions to convert the directory listing to ls -l format. ;; -;; 13. The famous @ bug. As mentioned above in TIPS, ULTRIX marks symlinks -;; with a trailing @ in a ls -alF listing. In order to account for this +;; 13. The famous @ bug. As mentioned above in TIPS, ULTRIX marks symlinks +;; with a trailing @ in a ls -alF listing. In order to account for this ;; ange-ftp looks to chop trailing @'s off of symlink names when it is -;; parsing a listing with the F switch. This will cause ange-ftp to +;; parsing a listing with the F switch. This will cause ange-ftp to ;; incorrectly get the name of a symlink on a non-ULTRIX host if its name -;; ends in an @. ange-ftp will correct itself if you take F out of the -;; dired ls switches (C-u s will allow you to edit the switches). The +;; ends in an @. ange-ftp will correct itself if you take F out of the +;; dired ls switches (C-u s will allow you to edit the switches). The ;; dired buffer will be automatically reverted, which will allow ange-ftp ;; to fix its files hashtable. A cookie to anyone who can think of a ;; fast, sure-fire way to recognize ULTRIX over ftp. @@ -576,26 +576,26 @@ ;; and the current code should eventually be made compliant. ;; ;; nil = local host type, whatever that is (probably unix). -;; Think nil as in "not a remote host". This value is used by +;; Think nil as in "not a remote host". This value is used by ;; ange-ftp-dired-host-type for local buffers. ;; -;; t = a remote host of unknown type. Think t as in true, it's remote. +;; t = a remote host of unknown type. Think t as in true, it's remote. ;; Currently, `unix' is used as the default remote host type. ;; Maybe we should use t. ;; ;; TYPE = a remote host of TYPE type. ;; ;; TYPE:LIST = a remote host of TYPE type, using a specialized ftp listing -;; program called list. This is currently only used for Unix +;; program called list. This is currently only used for Unix ;; dl (descriptive listings), when ange-ftp-dired-host-type ;; is set to `unix:dl'. ;; Bug report codes: ;; ;; Because of their naive faith in this code, there are certain situations -;; which the writers of this program believe could never happen. However, +;; which the writers of this program believe could never happen. However, ;; being realists they have put calls to `error' in the program at these -;; points. These errors provide a code, which is an integer, greater than 1. +;; points. These errors provide a code, which is an integer, greater than 1. ;; To aid debugging. the error codes, and the functions in which they reside ;; are listed below. ;; @@ -1025,7 +1025,7 @@ or nil meaning don't change it." "Buffer name to hold directory listing data received from FTP process.") (defvar ange-ftp-netrc-modtime nil - "Last modified time of the netrc file from file-attributes.") + "Last modified time of the netrc file from `file-attributes'.") (defvar ange-ftp-user-hashtable (make-hash-table :test 'equal) "Hash table holding associations between HOST, USER pairs.") @@ -1230,8 +1230,9 @@ only return the directory part of FILE." ;; found another machine with the same user. ;; Try that account. (read-passwd - (format "passwd for %s@%s (default same as %s@%s): " - user host user other) + (format-prompt "passwd for %s@%s" + (format "same as %s@%s" user other) + user host) nil (ange-ftp-lookup-passwd other user)) @@ -1357,7 +1358,7 @@ only return the directory part of FILE." (defun ange-ftp-parse-netrc () ;; We set this before actually doing it to avoid the possibility - ;; of an infinite loop if ange-ftp-netrc-filename is an FTP file. + ;; of an infinite loop if `ange-ftp-netrc-filename' is an FTP file. (interactive) (let (file attr) (let ((default-directory "/")) @@ -2296,7 +2297,7 @@ and NOWAIT." ;; If the dir name contains a space, some ftp servers will ;; refuse to list it. We instead change directory to the ;; directory in question and ls ".". - (when (string-match " " cmd1) + (when (string-search " " cmd1) ;; Keep the result. In case of failure, we will (see below) ;; short-circuit CMD and return this result directly. (setq result (ange-ftp-cd host user (nth 1 cmd) 'noerror)) @@ -2641,7 +2642,7 @@ away in the internal cache." (ange-ftp-error host user (concat "DIR failed: " (cdr result))))) (ange-ftp-del-tmp-name temp)))) - (error "Should never happen. Please report. Bug ref. no.: 1")))) + (error "This should never happen; please report this as a bug")))) ;;;; ------------------------------------------------------------ ;;;; Directory information caching support. @@ -2881,13 +2882,13 @@ NO-ERROR, if a listing for DIRECTORY cannot be obtained." (or ;; No dots in dir names in vms. (and (eq host-type 'vms) - (string-match "\\." efile)) + (string-search "." efile)) ;; No subdirs in mts of cms. (and (memq host-type '(mts cms)) (not (string-equal "/" (nth 2 parsed)))) ;; No dots in pseudo-dir names in bs2000. (and (eq host-type 'bs2000) - (string-match "\\." efile)))))) + (string-search "." efile)))))) (defun ange-ftp-file-entry-p (name) "Given NAME, return whether there is a file entry for it." @@ -3591,11 +3592,11 @@ Value is (0 0) if the modification time cannot be determined." (ange-ftp-real-verify-visited-file-modtime buf)))) (defun ange-ftp-file-size (file &optional ascii-mode) - "Return the size of remote file FILE. Return -1 if can't get it. -If ascii-mode is non-nil, return the size with the extra octets that + "Return the size of remote file FILE. Return -1 if can't get it. +If ASCII-MODE is non-nil, return the size with the extra octets that need to be inserted, one at the end of each line, to provide correct -end-of-line semantics for a transfer using TYPE=A. The default is nil, -so return the size on the remote host exactly. See RFC 3659." +end-of-line semantics for a transfer using TYPE=A. The default is nil, +so return the size on the remote host exactly. See RFC 3659." (let* ((parsed (ange-ftp-ftp-name file)) (host (nth 0 parsed)) (user (nth 1 parsed)) @@ -4704,8 +4705,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") ;; Can't use ange-ftp-dired-host-type here because the current ;; buffer is *dired-check-process output* (condition-case oops - (cond ((equal (or (bound-and-true-p dired-chmod-program) "chmod") - program) + (cond ((equal "chmod" program) (ange-ftp-call-chmod arguments)) ;; ((equal "chgrp" program)) ;; ((equal dired-chown-program program)) @@ -4724,7 +4724,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") ;; by using the ftp chmod command. (defun ange-ftp-call-chmod (args) (if (< (length args) 2) - (error "ange-ftp-call-chmod: missing mode and/or filename: %s" args)) + (error "ange-ftp-call-chmod: Missing mode and/or filename: %s" args)) (let ((mode (car args)) (rest (cdr args))) (if (equal "--" (car rest)) @@ -5135,7 +5135,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (concat "/" drive "/")) dir (and dir "/") file)) - (error "name %s didn't match" name)) + (error "Name %s didn't match" name)) (let (drive dir file tmp quote) (if (string-match "\\`\".+\"\\'" name) (setq name (substring name 1 -1) @@ -5663,7 +5663,7 @@ Other orders of $ and _ seem to all work just fine.") (setq file (match-string 2 name)) (concat (and acct (concat "/" acct "/")) file)) - (error "name %s didn't match" name)) + (error "Name %s didn't match" name)) (if (string-match "\\`/\\([^:]+:\\)/\\(.*\\)\\'" name) (concat (match-string 1 name) (match-string 2 name)) ;; Let's hope that mts will recognize it anyway. @@ -6097,7 +6097,7 @@ Other orders of $ and _ seem to all work just fine.") (and pubset (concat "_/" pubset "/")) (and userid (concat userid "/")) filename)) - (error "name %s didn't match" name)) + (error "Name %s didn't match" name)) ;; and here we (maybe) have to remove the inserted "_/" 'cause ;; of our prevention of the special escape prefix above: (if (string-match (concat "^/_/") name) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 96da0c5374f..1fafed32e6c 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -692,16 +692,11 @@ alist is deprecated. Use `browse-url-handlers' instead.") (defun browse-url-url-encode-chars (text chars) "URL-encode the chars in TEXT that match CHARS. -CHARS is a regexp-like character alternative (e.g., \"[)$]\")." - (let ((encoded-text (copy-sequence text)) - (s 0)) - (while (setq s (string-match chars encoded-text s)) - (setq encoded-text - (replace-match (format "%%%X" - (string-to-char (match-string 0 encoded-text))) - t t encoded-text) - s (1+ s))) - encoded-text)) +CHARS is a regexp that matches a character." + (replace-regexp-in-string chars + (lambda (s) + (format "%%%X" (string-to-char s))) + text)) (defun browse-url-encode-url (url) "Escape annoying characters in URL. @@ -710,7 +705,7 @@ regarding its parameter treatment." ;; FIXME: Is there an actual example of a web browser getting ;; confused? (This used to encode commas, but at least Firefox ;; handles commas correctly and doesn't accept encoded commas.) - (browse-url-url-encode-chars url "[\")$] ")) + (browse-url-url-encode-chars url "[\"()$ ]")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; URL input @@ -980,6 +975,7 @@ click but point is not changed." "Invoke the MS-Windows system's default Web browser. The optional NEW-WINDOW argument is not used." (interactive (browse-url-interactive-arg "URL: ")) + (setq url (browse-url-encode-url url)) (cond ((eq system-type 'ms-dos) (if dos-windows-version (shell-command (concat "start " (shell-quote-argument url))) @@ -1009,6 +1005,7 @@ The optional NEW-WINDOW argument is not used." "Invoke the macOS system's default Web browser. The optional NEW-WINDOW argument is not used." (interactive (browse-url-interactive-arg "URL: ")) + (setq url (browse-url-encode-url url)) (start-process (concat "open " url) nil "open" url)) (function-put 'browse-url-default-macosx-browser 'browse-url-browser-kind @@ -1612,7 +1609,7 @@ used instead of `browse-url-new-window-flag'." ;; --- mailto --- -(autoload 'rfc2368-parse-mailto-url "rfc2368") +(autoload 'rfc6068-parse-mailto-url "rfc6068") ;;;###autoload (defun browse-url-mail (url &optional new-window) @@ -1631,7 +1628,7 @@ When called non-interactively, optional second argument NEW-WINDOW is used instead of `browse-url-new-window-flag'." (interactive (browse-url-interactive-arg "Mailto URL: ")) (save-excursion - (let* ((alist (rfc2368-parse-mailto-url url)) + (let* ((alist (rfc6068-parse-mailto-url url)) (to (assoc "To" alist)) (subject (assoc "Subject" alist)) (body (assoc "Body" alist)) @@ -1653,7 +1650,7 @@ used instead of `browse-url-new-window-flag'." (insert "\n")) (goto-char (prog1 (point) - (insert (replace-regexp-in-string "\r\n" "\n" body)) + (insert (string-replace "\r\n" "\n" body)) (unless (bolp) (insert "\n")))))))) @@ -1766,11 +1763,11 @@ from `browse-url-elinks-wrapper'." (define-key map [mouse-2] #'browse-url-button-open) (define-key map "w" #'browse-url-button-copy) map) - "The keymap used for browse-url buttons.") + "The keymap used for `browse-url' buttons.") (defface browse-url-button '((t :inherit link)) - "Face for browse-url buttons (i.e., links)." + "Face for `browse-url' buttons (i.e., links)." :version "27.1") (defun browse-url-add-buttons () @@ -1789,6 +1786,7 @@ clickable and will use `browse-url' to open the URLs in question." category browse-url browse-url-data ,(match-string 0))))))) +;;;###autoload (defun browse-url-button-open (&optional external mouse-event) "Follow the link under point using `browse-url'. If EXTERNAL (the prefix if used interactively), open with the diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 4116d293e1b..3fff5398c06 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -2073,7 +2073,8 @@ either a method name, a signal name, or an error name." (goto-char point))) (defun dbus-monitor-handler (&rest _args) - "Default handler for the \"org.freedesktop.DBus.Monitoring.BecomeMonitor\" interface. + "Default handler for the \"Monitoring.BecomeMonitor\" interface. +Its full name is \"org.freedesktop.DBus.Monitoring.BecomeMonitor\". It will be applied for all objects created by `dbus-register-monitor' which don't declare an own handler. The printed timestamps do not reflect the time the D-Bus message has passed the D-Bus @@ -2251,15 +2252,19 @@ keywords `:system-private' or `:session-private', respectively." bus nil dbus-path-local dbus-interface-local "Disconnected" #'dbus-handle-bus-disconnect))) - -;; Initialize `:system' and `:session' buses. This adds their file -;; descriptors to input_wait_mask, in order to detect incoming -;; messages immediately. -(when (featurep 'dbusbind) - (dbus-ignore-errors - (dbus-init-bus :system)) - (dbus-ignore-errors - (dbus-init-bus :session))) + +(defun dbus--init () + ;; Initialize `:system' and `:session' buses. This adds their file + ;; descriptors to input_wait_mask, in order to detect incoming + ;; messages immediately. + (when (featurep 'dbusbind) + (dbus-ignore-errors + (dbus-init-bus :system)) + (dbus-ignore-errors + (dbus-init-bus :session)))) + +(add-hook 'after-pdump-load-hook #'dbus--init) +(dbus--init) (provide 'dbus) diff --git a/lisp/net/dictionary.el b/lisp/net/dictionary.el index f33cbaf1126..1d07989ef57 100644 --- a/lisp/net/dictionary.el +++ b/lisp/net/dictionary.el @@ -25,9 +25,9 @@ ;; dictionary allows you to interact with dictionary servers. ;; Use M-x customize-group dictionary to modify user settings. ;; -;; Main functions for interaction are: -;; dictionary - opens a new dictionary buffer -;; dictionary-search - search for the definition of a word +;; Main commands for interaction are: +;; M-x dictionary - opens a new dictionary buffer +;; M-x dictionary-search - search for the definition of a word ;; ;; You can find more information in the README file of the GitHub ;; repository https://github.com/myrkr/dictionary-el @@ -58,11 +58,11 @@ the existing connection." (set-default name value)) (defgroup dictionary nil - "Client for accessing the dictd server based dictionaries" + "Client for accessing the dictd server based dictionaries." :group 'hypermedia) (defgroup dictionary-proxy nil - "Proxy configuration options for the dictionary client" + "Proxy configuration options for the dictionary client." :group 'dictionary) (defcustom dictionary-server @@ -86,7 +86,7 @@ You can specify here: (defcustom dictionary-port 2628 "The port of the dictionary server. -This port is propably always 2628 so there should be no need to modify it." +This port is probably always 2628 so there should be no need to modify it." :group 'dictionary :set #'dictionary-set-server-var :type 'number @@ -943,7 +943,6 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (defun dictionary-set-dictionary (param &optional more) "Select the dictionary which is the car of PARAM as new default." - (if more (dictionary-display-more-info param) (let ((dictionary (car param))) @@ -1050,8 +1049,7 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." 'dictionary-display-match-result))) (defun dictionary-do-matching (word dictionary strategy function) - "Find matches for WORD with STRATEGY in DICTIONARY and display them with FUNCTION." - + "Search for WORD with STRATEGY in DICTIONARY and display them with FUNCTION." (message "Lookup matching words for %s in %s using %s" word dictionary strategy) (dictionary-send-command @@ -1211,7 +1209,6 @@ allows editing it." (save-excursion (mouse-set-point event) (current-word))))) - (selected-window) (dictionary-popup-matching-words word))) ;;;###autoload @@ -1315,9 +1312,9 @@ allows editing it." "Turn off or on support for the dictionary tooltip mode. It is normally internally called with 1 to enable support for the -tooltip mode. The hook function will check the value of the -variable dictionary-tooltip-mode to decide if some action must be -taken. When disabling the tooltip mode the value of this variable +tooltip mode. The hook function will check the value of the +variable `dictionary-tooltip-mode' to decide if some action must be +taken. When disabling the tooltip mode the value of this variable will be set to nil." (interactive) (tooltip-mode on) @@ -1348,10 +1345,10 @@ active it will overwrite that mode for the current buffer." ;;;###autoload (defun global-dictionary-tooltip-mode (&optional arg) - "Enable/disable dictionary-tooltip-mode for all buffers. + "Enable/disable `dictionary-tooltip-mode' for all buffers. -Internally it provides a default for the dictionary-tooltip-mode. -It can be overwritten for each buffer using dictionary-tooltip-mode. +Internally it provides a default for the `dictionary-tooltip-mode'. +It can be overwritten for each buffer using `dictionary-tooltip-mode'. Note: (global-dictionary-tooltip-mode 0) will not disable the mode any buffer where (dictionary-tooltip-mode 1) has been called." @@ -1368,5 +1365,30 @@ any buffer where (dictionary-tooltip-mode 1) has been called." (if on #'dictionary-tooltip-track-mouse #'ignore)) on)) +;;; Context menu support + +(defun dictionary-search-word-at-mouse (event) + (interactive "e") + (let ((word (save-window-excursion + (save-excursion + (mouse-set-point event) + (current-word))))) + (dictionary-search word))) + +;;;###autoload +(defun context-menu-dictionary (menu click) + "Populate MENU with dictionary commands at CLICK. +When you add this function to `context-menu-functions', +the context menu will contain an item that searches +the word at mouse click." + (when (thing-at-mouse click 'word) + (define-key-after menu [dictionary-separator] menu-bar-separator + 'middle-separator) + (define-key-after menu [dictionary-search-word-at-mouse] + '(menu-item "Dictionary Search" dictionary-search-word-at-mouse + :help "Search the word at mouse click in dictionary") + 'dictionary-separator)) + menu) + (provide 'dictionary) ;;; dictionary.el ends here diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el index 1d7af7f5b5f..7ad92b22af7 100644 --- a/lisp/net/eudc-bob.el +++ b/lisp/net/eudc-bob.el @@ -252,17 +252,14 @@ display a button." ;; If the first arguments can be nil here, then these 3 can be ;; defconsts once more. -(easy-menu-define eudc-bob-generic-menu - eudc-bob-generic-keymap - "" +(easy-menu-define eudc-bob-generic-menu eudc-bob-generic-keymap + "EUDC Binary Object Menu." eudc-bob-generic-menu) -(easy-menu-define eudc-bob-image-menu - eudc-bob-image-keymap - "" +(easy-menu-define eudc-bob-image-menu eudc-bob-image-keymap + "EUDC Image Menu." eudc-bob-image-menu) -(easy-menu-define eudc-bob-sound-menu - eudc-bob-sound-keymap - "" +(easy-menu-define eudc-bob-sound-menu eudc-bob-sound-keymap + "EUDC Sound Menu." eudc-bob-sound-menu) ;;;###autoload diff --git a/lisp/net/eudc-hotlist.el b/lisp/net/eudc-hotlist.el index a737a99ce95..43c1a2886f6 100644 --- a/lisp/net/eudc-hotlist.el +++ b/lisp/net/eudc-hotlist.el @@ -174,9 +174,8 @@ These are the special commands of this mode: ["Save and Quit" eudc-hotlist-quit-edit t] ["Exit without Saving" kill-this-buffer t])) -(easy-menu-define eudc-hotlist-emacs-menu - eudc-hotlist-mode-map - "" +(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 6459c52afee..14e5c28b2dc 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -25,7 +25,7 @@ ;;; Commentary: ;; This package provides a common interface to query directory servers using ;; different protocols such as LDAP, CCSO PH/QI or BBDB. Queries can be -;; made through an interactive form or inline. Inline query strings in +;; made through an interactive form or inline. Inline query strings in ;; buffers are expanded with appropriately formatted query results ;; (especially used to expand email addresses in message buffers). EUDC ;; also interfaces with the BBDB package to let you register query results @@ -664,7 +664,7 @@ If ERROR is non-nil, report an error if there is none." (let ((result (eudc-query (list (cons 'name name)) '(email))) email) (if (null (cdr result)) - (setq email (cl-cdaar result)) + (setq email (cdaar result)) (error "Multiple match--use the query form")) (if error (if email @@ -682,7 +682,7 @@ If ERROR is non-nil, report an error if there is none." (let ((result (eudc-query (list (cons 'name name)) '(phone))) phone) (if (null (cdr result)) - (setq phone (cl-cdaar result)) + (setq phone (cdaar result)) (error "Multiple match--use the query form")) (if error (if phone @@ -798,8 +798,9 @@ see `eudc-inline-expansion-servers'." "Query the directory server, and return the matching responses. The variable `eudc-inline-query-format' controls how to associate the individual QUERY-WORDS with directory attribute names. -After querying the server for the given string, the expansion specified by -`eudc-inline-expansion-format' is applied to the matches before returning them.inserted in the buffer at point. +After querying the server for the given string, the expansion +specified by `eudc-inline-expansion-format' is applied to the +matches before returning them.inserted in the buffer at point. Multiple servers can be tried with the same query until one finds a match, see `eudc-inline-expansion-servers'." (cond diff --git a/lisp/net/eudcb-ldap.el b/lisp/net/eudcb-ldap.el index 0aff276475e..fc486567265 100644 --- a/lisp/net/eudcb-ldap.el +++ b/lisp/net/eudcb-ldap.el @@ -202,7 +202,7 @@ attribute names are returned. Default to `person'." "Check if the current LDAP server has a configured search base." (unless (or (eudc-ldap-get-host-parameter eudc-server 'base) ldap-default-base - (null (y-or-n-p "No search base defined. Configure it now? "))) + (null (y-or-n-p "No search base defined. Configure it now?"))) ;; If the server is not in ldap-host-parameters-alist we add it for the ;; user (if (null (assoc eudc-server ldap-host-parameters-alist)) diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 5f97027aae4..46e211171e6 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -36,7 +36,7 @@ (eval-when-compile (require 'subr-x)) (defgroup eww nil - "Emacs Web Wowser" + "Emacs Web Wowser." :version "25.1" :link '(custom-manual "(eww) Top") :group 'web @@ -57,7 +57,7 @@ :type 'string) (defcustom eww-use-browse-url "\\`mailto:" - "eww will use `browse-url' when following links that match this regexp. + "EWW will use `browse-url' when following links that match this regexp. The action to be taken can be further customized via `browse-url-handlers'." :version "28.1" @@ -143,12 +143,14 @@ The string will be passed through `substitute-command-keys'." (defcustom eww-retrieve-command nil "Command to retrieve an URL via an external program. -If nil, `url-retrieve' is used to download the data. If non-nil, -this should be a list where the first item is the program, and -the rest are the arguments." +If nil, `url-retrieve' is used to download the data. +If `sync', `url-retrieve-synchronously' is used. +For other non-nil values, this should be a list of strings where +the first item is the program, and the rest are the arguments." :version "28.1" :type '(choice (const :tag "Use `url-retrieve'" nil) - (repeat string))) + (const :tag "Use `url-retrieve-synchronously'" sync) + (repeat :tag "Command/args" string ))) (defcustom eww-use-external-browser-for-content-type "\\`\\(video/\\|audio/\\|application/ogg\\)" @@ -176,6 +178,40 @@ the tab bar is enabled." :group 'eww :type 'hook) +(defcustom eww-auto-rename-buffer nil + "Automatically rename EWW buffers once the page is rendered. + +When nil, do not rename the buffer. With a non-nil value +determine the renaming scheme, as follows: + +- `title': Use the web page's title. +- `url': Use the web page's URL. +- a function's symbol: Run a user-defined function that returns a + string with which to rename the buffer. Sample of a + user-defined function: + + (defun my-eww-rename-buffer () + (when (eq major-mode 'eww-mode) + (when-let ((string (or (plist-get eww-data :title) + (plist-get eww-data :url)))) + (format \"*%s*\" string)))) + +The string of `title' and `url' is always truncated to the value +of `eww-buffer-name-length'." + :version "29.1" + :type '(choice + (const :tag "Do not rename buffers (default)" nil) + (const :tag "Rename buffer to web page title" title) + (const :tag "Rename buffer to web page URL" url) + (function :tag "A user-defined function to rename the buffer")) + :group 'eww) + +(defcustom eww-buffer-name-length 40 + "Length of renamed buffer name, per `eww-auto-rename-buffer'." + :type 'natnum + :version "29.1" + :group 'eww) + (defcustom eww-form-checkbox-selected-symbol "[X]" "Symbol used to represent a selected checkbox. See also `eww-form-checkbox-symbol'." @@ -195,6 +231,13 @@ See also `eww-form-checkbox-selected-symbol'." (const "☐") ; Unicode BALLOT BOX string)) +(defcustom eww-url-transformers '(eww-remove-tracking) + "This is a list of transforming functions applied to an URL before usage. +The functions will be called with the URL as the single +parameter, and should return the (possibly) transformed URL." + :type '(repeat function) + :version "29.1") + (defface eww-form-submit '((((type x w32 ns pgtk) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) @@ -269,15 +312,13 @@ See also `eww-form-checkbox-selected-symbol'." "text/html, text/plain, text/sgml, text/css, application/xhtml+xml, */*;q=0.01" "Value used for the HTTP 'Accept' header.") -(defvar eww-link-keymap - (let ((map (copy-keymap shr-map))) - (define-key map "\r" 'eww-follow-link) - map)) +(defvar-keymap eww-link-keymap + :parent shr-map + "\r" #'eww-follow-link) -(defvar eww-image-link-keymap - (let ((map (copy-keymap shr-image-map))) - (define-key map "\r" 'eww-follow-link) - map)) +(defvar-keymap eww-image-link-keymap + :parent shr-map + "\r" #'eww-follow-link) (defun eww-suggested-uris nil "Return the list of URIs to suggest at the `eww' prompt. @@ -311,13 +352,13 @@ will start Emacs and browse the GNU web site." ;;;###autoload -(defun eww (url &optional arg buffer) +(defun eww (url &optional new-buffer buffer) "Fetch URL and render the page. If the input doesn't look like an URL or a domain name, the word(s) will be searched for via `eww-search-prefix'. -If called with a prefix ARG, use a new buffer instead of reusing -the default EWW buffer. +If NEW-BUFFER is non-nil (interactively, the prefix arg), use a +new buffer instead of reusing the default EWW buffer. If BUFFER, the data to be rendered is in that buffer. In that case, this function doesn't actually fetch URL. BUFFER will be @@ -327,11 +368,11 @@ killed after rendering." (list (read-string (format-prompt "Enter URL or keywords" (and uris (car uris))) nil 'eww-prompt-history uris) - (prefix-numeric-value current-prefix-arg)))) + current-prefix-arg))) (setq url (eww--dwim-expand-url url)) (pop-to-buffer-same-window (cond - ((eq arg 4) + (new-buffer (generate-new-buffer "*eww*")) ((eq major-mode 'eww-mode) (current-buffer)) @@ -351,9 +392,10 @@ killed after rendering." (while (string-match "\\`/[.][.]/" (url-filename parsed)) (setf (url-filename parsed) (substring (url-filename parsed) 3)))) (setq url (url-recreate-url parsed))) + (setq url (eww--transform-url url)) (plist-put eww-data :url url) (plist-put eww-data :title "") - (eww-update-header-line-format) + (eww--after-page-change) (let ((inhibit-read-only t)) (insert (format "Loading %s..." url)) (goto-char (point-min))) @@ -366,9 +408,16 @@ killed after rendering." (list url nil (current-buffer)))))) (defun eww-retrieve (url callback cbargs) - (if (null eww-retrieve-command) - (url-retrieve url #'eww-render - (list url nil (current-buffer))) + (cond + ((null eww-retrieve-command) + (url-retrieve url #'eww-render + (list url nil (current-buffer)))) + ((eq eww-retrieve-command 'sync) + (let ((orig-buffer (current-buffer)) + (data-buffer (url-retrieve-synchronously url))) + (with-current-buffer data-buffer + (eww-render nil url nil orig-buffer)))) + (t (let ((buffer (generate-new-buffer " *eww retrieve*")) (error-buffer (generate-new-buffer " *eww error*"))) (with-current-buffer buffer @@ -388,7 +437,7 @@ killed after rendering." (with-current-buffer buffer (goto-char (point-min)) (insert "Content-type: text/html; charset=utf-8\n\n") - (apply #'funcall callback nil cbargs)))))))))) + (apply #'funcall callback nil cbargs))))))))))) (function-put 'eww 'browse-url-browser-kind 'internal) @@ -495,6 +544,30 @@ Currently this means either text/html or application/xhtml+xml." (member content-type '("text/html" "application/xhtml+xml"))) +(defun eww--rename-buffer () + "Rename the current EWW buffer. +The renaming scheme is performed in accordance with +`eww-auto-rename-buffer'." + (let ((rename-string) + (formatter + (lambda (string) + (format "*%s # eww*" (truncate-string-to-width + string eww-buffer-name-length)))) + (site-title (plist-get eww-data :title)) + (site-url (plist-get eww-data :url))) + (cond ((null eww-auto-rename-buffer)) + ((eq eww-auto-rename-buffer 'url) + (setq rename-string (funcall formatter site-url))) + ((functionp eww-auto-rename-buffer) + (setq rename-string (funcall eww-auto-rename-buffer))) + (t (setq rename-string + (funcall formatter (if (or (equal site-title "") + (null site-title)) + "Untitled" + site-title))))) + (when rename-string + (rename-buffer rename-string t)))) + (defun eww-render (status url &optional point buffer encode) (let* ((headers (eww-parse-headers)) (content-type @@ -545,7 +618,7 @@ Currently this means either text/html or application/xhtml+xml." (eww-display-raw buffer (or encode charset 'utf-8)))) (with-current-buffer buffer (plist-put eww-data :url url) - (eww-update-header-line-format) + (eww--after-page-change) (setq eww-history-position 0) (and last-coding-system-used (set-buffer-file-coding-system last-coding-system-used)) @@ -629,7 +702,8 @@ Currently this means either text/html or application/xhtml+xml." (meta . eww-tag-meta) (a . eww-tag-a))))) (erase-buffer) - (shr-insert-document document) + (with-delayed-message (2 "Rendering HTML...") + (shr-insert-document document)) (cond (point (goto-char point)) @@ -668,9 +742,12 @@ Currently this means either text/html or application/xhtml+xml." ("home" . :home) ("contents" . :contents) ("up" . :up))))) - (and href - where - (plist-put eww-data (cdr where) href)))) + (when (and href where) + (when (memq (cdr where) '(:next :previous)) + ;; Multi-page isearch support. + (setq-local multi-isearch-next-buffer-function + #'eww-isearch-next-buffer)) + (plist-put eww-data (cdr where) href)))) (defvar eww-redirect-level 1) @@ -779,19 +856,23 @@ Currently this means either text/html or application/xhtml+xml." (propertize "...: " 'face 'variable-pitch)))) (propertize "..." 'face 'variable-pitch))))))) - (replace-regexp-in-string + (string-replace "%" "%%" (format-spec eww-header-line-format `((?u . ,(or url "")) (?t . ,title)))))))) +(defun eww--after-page-change () + (eww-update-header-line-format) + (eww--rename-buffer)) + (defun eww-tag-title (dom) (plist-put eww-data :title (replace-regexp-in-string "^ \\| $" "" (replace-regexp-in-string "[ \t\r\n]+" " " (dom-text dom)))) - (eww-update-header-line-format)) + (eww--after-page-change)) (defun eww-display-raw (buffer &optional encode) (let ((data (buffer-substring (point) (point-max)))) @@ -840,6 +921,8 @@ Currently this means either text/html or application/xhtml+xml." (remove-overlays) (erase-buffer)) (setq bidi-paragraph-direction nil) + ;; May be set later if there's a next/prev link. + (setq-local multi-isearch-next-buffer-function nil) (unless (eq major-mode 'eww-mode) (eww-mode))) @@ -917,7 +1000,7 @@ the like." nil (current-buffer)) (dolist (elem '(:source :url :title :next :previous :up)) (plist-put eww-data elem (plist-get old-data elem))) - (eww-update-header-line-format))) + (eww--after-page-change))) (defun eww-score-readability (node) (let ((score -1)) @@ -959,67 +1042,97 @@ the like." (setq result highest)))) result)) -(defvar eww-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "g" 'eww-reload) ;FIXME: revert-buffer-function instead! - (define-key map "G" 'eww) - (define-key map [?\M-\r] 'eww-open-in-new-buffer) - (define-key map [?\t] 'shr-next-link) - (define-key map [?\M-\t] 'shr-previous-link) - (define-key map [backtab] 'shr-previous-link) - (define-key map [delete] 'scroll-down-command) - (define-key map "l" 'eww-back-url) - (define-key map "r" 'eww-forward-url) - (define-key map "n" 'eww-next-url) - (define-key map "p" 'eww-previous-url) - (define-key map "u" 'eww-up-url) - (define-key map "t" 'eww-top-url) - (define-key map "&" 'eww-browse-with-external-browser) - (define-key map "d" 'eww-download) - (define-key map "w" 'eww-copy-page-url) - (define-key map "C" 'url-cookie-list) - (define-key map "v" 'eww-view-source) - (define-key map "R" 'eww-readable) - (define-key map "H" 'eww-list-histories) - (define-key map "E" 'eww-set-character-encoding) - (define-key map "s" 'eww-switch-to-buffer) - (define-key map "S" 'eww-list-buffers) - (define-key map "F" 'eww-toggle-fonts) - (define-key map "D" 'eww-toggle-paragraph-direction) - (define-key map [(meta C)] 'eww-toggle-colors) - (define-key map [(meta I)] 'eww-toggle-images) - - (define-key map "b" 'eww-add-bookmark) - (define-key map "B" 'eww-list-bookmarks) - (define-key map [(meta n)] 'eww-next-bookmark) - (define-key map [(meta p)] 'eww-previous-bookmark) - - (easy-menu-define nil map "" +(defvar-keymap eww-mode-map + "g" #'eww-reload ;FIXME: revert-buffer-function instead! + "G" #'eww + [?\M-\r] #'eww-open-in-new-buffer + [?\t] #'shr-next-link + [?\M-\t] #'shr-previous-link + [backtab] #'shr-previous-link + [delete] #'scroll-down-command + "l" #'eww-back-url + "r" #'eww-forward-url + "n" #'eww-next-url + "p" #'eww-previous-url + "u" #'eww-up-url + "t" #'eww-top-url + "&" #'eww-browse-with-external-browser + "d" #'eww-download + "w" #'eww-copy-page-url + "C" #'url-cookie-list + "v" #'eww-view-source + "R" #'eww-readable + "H" #'eww-list-histories + "E" #'eww-set-character-encoding + "s" #'eww-switch-to-buffer + "S" #'eww-list-buffers + "F" #'eww-toggle-fonts + "D" #'eww-toggle-paragraph-direction + [(meta C)] #'eww-toggle-colors + [(meta I)] #'eww-toggle-images + + "b" #'eww-add-bookmark + "B" #'eww-list-bookmarks + [(meta n)] #'eww-next-bookmark + [(meta p)] #'eww-previous-bookmark + + [(mouse-8)] #'eww-back-url + [(mouse-9)] #'eww-forward-url + + :menu '("Eww" + ["Exit" quit-window t] + ["Close browser" quit-window t] + ["Reload" eww-reload t] + ["Follow URL in new buffer" eww-open-in-new-buffer] + ["Back to previous page" eww-back-url + :active (not (zerop (length eww-history)))] + ["Forward to next page" eww-forward-url + :active (not (zerop eww-history-position))] + ["Browse with external browser" eww-browse-with-external-browser t] + ["Download" eww-download t] + ["View page source" eww-view-source] + ["Copy page URL" eww-copy-page-url t] + ["List histories" eww-list-histories t] + ["Switch to buffer" eww-switch-to-buffer t] + ["List buffers" eww-list-buffers t] + ["Add bookmark" eww-add-bookmark t] + ["List bookmarks" eww-list-bookmarks t] + ["List cookies" url-cookie-list t] + ["Toggle fonts" eww-toggle-fonts t] + ["Toggle colors" eww-toggle-colors t] + ["Toggle images" eww-toggle-images t] + ["Character Encoding" eww-set-character-encoding] + ["Toggle Paragraph Direction" eww-toggle-paragraph-direction])) + +(defun eww-context-menu (menu click) + "Populate MENU with eww commands at CLICK." + (define-key menu [eww-separator] menu-bar-separator) + (let ((easy-menu (make-sparse-keymap "Eww"))) + (easy-menu-define nil easy-menu nil '("Eww" - ["Exit" quit-window t] - ["Close browser" quit-window t] - ["Reload" eww-reload t] - ["Follow URL in new buffer" eww-open-in-new-buffer] - ["Back to previous page" eww-back-url - :active (not (zerop (length eww-history)))] + ["Back to previous page" eww-back-url + :visible (not (zerop (length eww-history)))] ["Forward to next page" eww-forward-url - :active (not (zerop eww-history-position))] - ["Browse with external browser" eww-browse-with-external-browser t] - ["Download" eww-download t] - ["View page source" eww-view-source] - ["Copy page URL" eww-copy-page-url t] - ["List histories" eww-list-histories t] - ["Switch to buffer" eww-switch-to-buffer t] - ["List buffers" eww-list-buffers t] - ["Add bookmark" eww-add-bookmark t] - ["List bookmarks" eww-list-bookmarks t] - ["List cookies" url-cookie-list t] - ["Toggle fonts" eww-toggle-fonts t] - ["Toggle colors" eww-toggle-colors t] - ["Toggle images" eww-toggle-images t] - ["Character Encoding" eww-set-character-encoding] - ["Toggle Paragraph Direction" eww-toggle-paragraph-direction])) - map)) + :visible (not (zerop eww-history-position))] + ["Reload" eww-reload t])) + (dolist (item (reverse (lookup-key easy-menu [menu-bar eww]))) + (when (consp item) + (define-key menu (vector (car item)) (cdr item))))) + + (when (or (mouse-posn-property (event-start click) 'shr-url) + (mouse-posn-property (event-start click) 'image-url)) + (define-key menu [shr-mouse-browse-url-new-window] + `(menu-item "Follow URL in new window" ,(if browse-url-new-window-flag + 'shr-mouse-browse-url + 'shr-mouse-browse-url-new-window) + :help "Browse the URL under the mouse cursor in a new window")) + (define-key menu [shr-mouse-browse-url] + `(menu-item "Follow URL" ,(if browse-url-new-window-flag + 'shr-mouse-browse-url-new-window + 'shr-mouse-browse-url) + :help "Browse the URL under the mouse cursor"))) + + menu) (defvar eww-tool-bar-map (let ((map (make-sparse-keymap))) @@ -1039,23 +1152,25 @@ the like." ;; Autoload cookie needed by desktop.el. ;;;###autoload (define-derived-mode eww-mode special-mode "eww" - "Mode for browsing the web." + "Mode for browsing the web. + +\\{eww-mode-map}" :interactive nil (setq-local eww-data (list :title "")) (setq-local browse-url-browser-function #'eww-browse-url) (add-hook 'after-change-functions #'eww-process-text-input nil t) + (add-hook 'context-menu-functions 'eww-context-menu 5 t) (setq-local eww-history nil) (setq-local eww-history-position 0) (when (boundp 'tool-bar-map) (setq-local tool-bar-map eww-tool-bar-map)) ;; desktop support (setq-local desktop-save-buffer #'eww-desktop-misc-data) - ;; multi-page isearch support - (setq-local multi-isearch-next-buffer-function #'eww-isearch-next-buffer) (setq truncate-lines t) (setq-local thing-at-point-provider-alist (append thing-at-point-provider-alist '((url . eww--url-at-point)))) + (setq-local bookmark-make-record-function #'eww-bookmark-make-record) (buffer-disable-undo) (setq buffer-read-only t)) @@ -1120,7 +1235,7 @@ instead of `browse-url-new-window-flag'." (goto-char (plist-get elem :point)) ;; Make buffer listings more informative. (setq list-buffers-directory (plist-get elem :url)) - (eww-update-header-line-format)))) + (eww--after-page-change)))) (defun eww-next-url () "Go to the page marked `next'. @@ -1184,54 +1299,43 @@ just re-display the HTML already fetched." (defvar eww-form nil) -(defvar eww-submit-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-submit) - (define-key map [(control c) (control c)] 'eww-submit) - map)) - -(defvar eww-submit-file - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-select-file) - (define-key map [(control c) (control c)] 'eww-submit) - map)) - -(defvar eww-checkbox-map - (let ((map (make-sparse-keymap))) - (define-key map " " 'eww-toggle-checkbox) - (define-key map "\r" 'eww-toggle-checkbox) - (define-key map [(control c) (control c)] 'eww-submit) - map)) - -(defvar eww-text-map - (let ((map (make-keymap))) - (set-keymap-parent map text-mode-map) - (define-key map "\r" 'eww-submit) - (define-key map [(control a)] 'eww-beginning-of-text) - (define-key map [(control c) (control c)] 'eww-submit) - (define-key map [(control e)] 'eww-end-of-text) - (define-key map [?\t] 'shr-next-link) - (define-key map [?\M-\t] 'shr-previous-link) - (define-key map [backtab] 'shr-previous-link) - map)) - -(defvar eww-textarea-map - (let ((map (make-keymap))) - (set-keymap-parent map text-mode-map) - (define-key map "\r" 'forward-line) - (define-key map [(control c) (control c)] 'eww-submit) - (define-key map [?\t] 'shr-next-link) - (define-key map [?\M-\t] 'shr-previous-link) - (define-key map [backtab] 'shr-previous-link) - map)) - -(defvar eww-select-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-change-select) - (define-key map [follow-link] 'mouse-face) - (define-key map [mouse-2] 'eww-change-select) - (define-key map [(control c) (control c)] 'eww-submit) - map)) +(defvar-keymap eww-submit-map + "\r" #'eww-submit + [(control c) (control c)] #'eww-submit) + +(defvar-keymap eww-submit-file + "\r" #'eww-select-file + [(control c) (control c)] #'eww-submit) + +(defvar-keymap eww-checkbox-map + " " #'eww-toggle-checkbox + "\r" #'eww-toggle-checkbox + [(control c) (control c)] #'eww-submit) + +(defvar-keymap eww-text-map + :full t :parent text-mode-map + "\r" #'eww-submit + [(control a)] #'eww-beginning-of-text + [(control c) (control c)] #'eww-submit + [(control e)] #'eww-end-of-text + [?\t] #'shr-next-link + [?\M-\t] #'shr-previous-link + [backtab] #'shr-previous-link) + +(defvar-keymap eww-textarea-map + :full t :parent text-mode-map + "\r" #'forward-line + [(control c) (control c)] #'eww-submit + [?\t] #'shr-next-link + [?\M-\t] #'shr-previous-link + [backtab] #'shr-previous-link) + +(defvar-keymap eww-select-map + :doc "Map for select buttons" + "\r" #'eww-change-select + [follow-link] 'mouse-face + [mouse-2] #'eww-change-select + [(control c) (control c)] #'eww-submit) (defun eww-beginning-of-text () "Move to the start of the input field." @@ -1738,6 +1842,17 @@ The browser to used is specified by the (funcall browse-url-secondary-browser-function (or url (plist-get eww-data :url)))) +(defun eww-remove-tracking (url) + "Remove the commong utm_ tracking cookies from URLs." + (replace-regexp-in-string ".utm_.*" "" url)) + +(defun eww--transform-url (url) + "Appy `eww-url-transformers'." + (when url + (dolist (func eww-url-transformers) + (setq url (funcall func url))) + url)) + (defun eww-follow-link (&optional external mouse-event) "Browse the URL under point. If EXTERNAL is single prefix, browse the URL using @@ -1748,7 +1863,8 @@ If EXTERNAL is double prefix, browse in new buffer." (list current-prefix-arg last-nonmenu-event) eww-mode) (mouse-set-point mouse-event) - (let ((url (get-text-property (point) 'shr-url))) + (let* ((orig-url (get-text-property (point) 'shr-url)) + (url (eww--transform-url orig-url))) (cond ((not url) (message "No link under point")) @@ -1767,7 +1883,7 @@ If EXTERNAL is double prefix, browse in new buffer." (plist-put eww-data :url url) (eww-display-html 'utf-8 url dom nil (current-buffer)))) (t - (eww-browse-url url external))))) + (eww-browse-url orig-url external))))) (defun eww-same-page-p (url1 url2) "Return non-nil if URL1 and URL2 represent the same page. @@ -1855,7 +1971,7 @@ Use link at point if there is one, else the current page's URL." (defun eww-set-character-encoding (charset) "Set character encoding to CHARSET. If CHARSET is nil then use UTF-8." - (interactive "zUse character set (default utf-8): " eww-mode) + (interactive "zUse character set (default `utf-8'): " eww-mode) (if (null charset) (eww-reload nil 'utf-8) (eww-reload nil charset))) @@ -2054,23 +2170,18 @@ If ERROR-OUT, signal user-error if there are no bookmarks." 'eww-bookmark))) (eww-browse-url (plist-get bookmark :url)))) -(defvar eww-bookmark-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control k)] 'eww-bookmark-kill) - (define-key map [(control y)] 'eww-bookmark-yank) - (define-key map "\r" 'eww-bookmark-browse) - - (easy-menu-define nil map - "Menu for `eww-bookmark-mode-map'." - '("Eww Bookmark" - ["Exit" quit-window t] - ["Browse" eww-bookmark-browse - :active (get-text-property (line-beginning-position) 'eww-bookmark)] - ["Kill" eww-bookmark-kill - :active (get-text-property (line-beginning-position) 'eww-bookmark)] - ["Yank" eww-bookmark-yank - :active eww-bookmark-kill-ring])) - map)) +(defvar-keymap eww-bookmark-mode-map + [(control k)] #'eww-bookmark-kill + [(control y)] #'eww-bookmark-yank + "\r" #'eww-bookmark-browse + :menu '("Eww Bookmark" + ["Exit" quit-window t] + ["Browse" eww-bookmark-browse + :active (get-text-property (line-beginning-position) 'eww-bookmark)] + ["Kill" eww-bookmark-kill + :active (get-text-property (line-beginning-position) 'eww-bookmark)] + ["Yank" eww-bookmark-yank + :active eww-bookmark-kill-ring])) (define-derived-mode eww-bookmark-mode special-mode "eww bookmarks" "Mode for listing bookmarks. @@ -2135,19 +2246,15 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (pop-to-buffer-same-window buffer))) (eww-restore-history history))) -(defvar eww-history-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-history-browse) - (define-key map "n" 'next-line) - (define-key map "p" 'previous-line) - - (easy-menu-define nil map - "Menu for `eww-history-mode-map'." - '("Eww History" - ["Exit" quit-window t] - ["Browse" eww-history-browse - :active (get-text-property (line-beginning-position) 'eww-history)])) - map)) +(defvar-keymap eww-history-mode-map + "\r" #'eww-history-browse + "n" #'next-line + "p" #'previous-line + :menu '("Eww History" + ["Exit" quit-window t] + ["Browse" eww-history-browse + :active (get-text-property (line-beginning-position) + 'eww-history)])) (define-derived-mode eww-history-mode special-mode "eww history" "Mode for listing eww-histories. @@ -2258,22 +2365,18 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (forward-line -1)) (eww-buffer-show)) -(defvar eww-buffers-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control k)] 'eww-buffer-kill) - (define-key map "\r" 'eww-buffer-select) - (define-key map "n" 'eww-buffer-show-next) - (define-key map "p" 'eww-buffer-show-previous) - - (easy-menu-define nil map - "Menu for `eww-buffers-mode-map'." - '("Eww Buffers" - ["Exit" quit-window t] - ["Select" eww-buffer-select - :active (get-text-property (line-beginning-position) 'eww-buffer)] - ["Kill" eww-buffer-kill - :active (get-text-property (line-beginning-position) 'eww-buffer)])) - map)) +(defvar-keymap eww-buffers-mode-map + [(control k)] #'eww-buffer-kill + "\r" #'eww-buffer-select + "n" #'eww-buffer-show-next + "p" #'eww-buffer-show-previous + :menu '("Eww Buffers" + ["Exit" quit-window t] + ["Select" eww-buffer-select + :active (get-text-property (line-beginning-position) 'eww-buffer)] + ["Kill" eww-buffer-kill + :active (get-text-property (line-beginning-position) + 'eww-buffer)])) (define-derived-mode eww-buffers-mode special-mode "eww buffers" "Mode for listing buffers. @@ -2364,15 +2467,38 @@ Otherwise, the restored buffer will contain a prompt to do so by using (defun eww-isearch-next-buffer (&optional _buffer wrap) "Go to the next page to search using `rel' attribute for navigation." - (if wrap - (condition-case nil - (eww-top-url) - (error nil)) - (if isearch-forward - (eww-next-url) - (eww-previous-url))) + (let ((eww-retrieve-command 'sync)) + (if wrap + (condition-case nil + (eww-top-url) + (error nil)) + (if isearch-forward + (eww-next-url) + (eww-previous-url)))) (current-buffer)) +;;; bookmark.el support + +(declare-function bookmark-make-record-default + "bookmark" (&optional no-file no-context posn)) +(declare-function bookmark-prop-get "bookmark" (bookmark prop)) + +(defun eww-bookmark-name () + "Create a default bookmark name for the current EWW buffer." + (plist-get eww-data :title)) + +(defun eww-bookmark-make-record () + "Create a bookmark for the current EWW buffer." + `(,(eww-bookmark-name) + ,@(bookmark-make-record-default t) + (location . ,(plist-get eww-data :url)) + (handler . eww-bookmark-jump))) + +;;;###autoload +(defun eww-bookmark-jump (bookmark) + "Default bookmark handler for EWW buffers." + (eww (bookmark-prop-get bookmark 'location))) + (provide 'eww) ;;; eww.el ends here diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index 43dd9dc15cd..7b1ea2e765e 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -226,7 +226,7 @@ trust and key files, and priority string." trustfiles crlfiles keylist min-prime-bits verify-flags verify-error verify-hostname-error &allow-other-keys) - "Negotiate a SSL/TLS connection. Returns proc. Signals gnutls-error. + "Negotiate a SSL/TLS connection. Return proc. Signal gnutls-error. Note that arguments are passed CL style, :type TYPE instead of just TYPE. diff --git a/lisp/net/goto-addr.el b/lisp/net/goto-addr.el index 8992ef736a6..848bad3b0d6 100644 --- a/lisp/net/goto-addr.el +++ b/lisp/net/goto-addr.el @@ -124,6 +124,15 @@ will have no effect.") m) "Keymap to hold goto-addr's mouse key defs under highlighted URLs.") +(defun goto-address-context-menu (menu click) + "Populate MENU with `goto-address' commands at CLICK." + (when (mouse-posn-property (event-start click) 'goto-address) + (define-key menu [goto-address-separator] menu-bar-separator) + (define-key menu [goto-address-at-mouse] + '(menu-item "Follow Link" goto-address-at-mouse + :help "Follow a link where you click"))) + menu) + (defcustom goto-address-url-face 'link "Face to use for URLs." :type 'face) @@ -245,6 +254,11 @@ address. If no e-mail address found, return nil." (goto-char (match-beginning 0)))) (match-string-no-properties 0))) +(defun goto-address-at-mouse (click) + "Send to the e-mail address or load the URL at mouse click." + (interactive "e") + (goto-address-at-point click)) + ;;;###autoload (defun goto-address () "Sets up goto-address functionality in the current buffer. @@ -264,12 +278,16 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and (define-minor-mode goto-address-mode "Minor mode to buttonize URLs and e-mail addresses in the current buffer." :lighter "" - (if goto-address-mode - (jit-lock-register #'goto-address-fontify-region) + (cond + (goto-address-mode + (jit-lock-register #'goto-address-fontify-region) + (add-hook 'context-menu-functions 'goto-address-context-menu 10 t)) + (t (jit-lock-unregister #'goto-address-fontify-region) (save-restriction (widen) - (goto-address-unfontify (point-min) (point-max))))) + (goto-address-unfontify (point-min) (point-max))) + (remove-hook 'context-menu-functions 'goto-address-context-menu t)))) (defun goto-addr-mode--turn-on () (when (not goto-address-mode) diff --git a/lisp/net/hmac-def.el b/lisp/net/hmac-def.el index 5ea8839699d..5778857ff80 100644 --- a/lisp/net/hmac-def.el +++ b/lisp/net/hmac-def.el @@ -34,9 +34,10 @@ HMAC function is H(KEY XOR opad, H(KEY XOR ipad, TEXT)): H is a cryptographic hash function, such as SHA1 and MD5, which takes a string and return a digest of it (in binary form). -B is a byte-length of a block size of H. (B=64 for both SHA1 and MD5.) -L is a byte-length of hash outputs. (L=16 for MD5, L=20 for SHA1.) +B is a byte length of a block size of H. (B=64 for both SHA1 and MD5.) +L is a byte length of hash outputs. (L=16 for MD5, L=20 for SHA1.) If BIT is non-nil, truncate output to specified bits." + (declare (indent defun)) `(defun ,name (text key) ,(concat "Compute " (upcase (symbol-name name)) diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el index 7997bf3c90b..8b35a2d8e16 100644 --- a/lisp/net/ldap.el +++ b/lisp/net/ldap.el @@ -51,7 +51,8 @@ a separator." (defcustom ldap-default-port nil "Default TCP port for LDAP connections. -Initialized from the LDAP library at build time. Default value is 389." +Initialized from the LDAP library at build time. +Default value is 389." :type '(choice (const :tag "Use library default" nil) (integer :tag "Port number"))) @@ -153,8 +154,7 @@ Valid properties include: (string :tag "Argument"))) (defcustom ldap-ldapsearch-password-prompt-regexp "Enter LDAP Password: " - "A regular expression used to recognize the `ldapsearch' -program's password prompt." + "Regexp used to recognize the `ldapsearch' program's password prompt." :type 'regexp :version "25.1") diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el index 54f7f416aba..2c687557181 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -93,7 +93,7 @@ The elements of the list are alists of the following structure (type . MIME-TYPE) (test . TEST)) -where VIEWER is either a lisp command, e.g., a major-mode, or a +where VIEWER is either a Lisp command, e.g., a major mode, or a string containing a shell command for viewing files of the defined MIME-TYPE. In case of a shell command, %s will be replaced with the file. @@ -101,7 +101,7 @@ replaced with the file. MIME-TYPE is a regular expression being matched against the actual MIME type. It is implicitly surrounded with ^ and $. -TEST is a lisp form which is evaluated in order to test if the +TEST is a Lisp form which is evaluated in order to test if the entry should be chosen. The `test' entry is optional. When selecting a viewer for a given MIME type, the first viewer @@ -423,14 +423,6 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus (interactive (list nil t)) (when (or (not mailcap-parsed-p) force) - ;; Clear out all old data. - (setq mailcap--computed-mime-data nil) - ;; Add the Emacs-distributed defaults (which will be used as - ;; fallbacks). Do it this way instead of just copying the list, - ;; since entries are destructively modified. - (cl-loop for (major . minors) in mailcap-mime-data - do (cl-loop for (minor . entry) in minors - do (mailcap-add-mailcap-entry major minor entry))) (cond (path nil) ((getenv "MAILCAPS") @@ -447,18 +439,29 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus ("/etc/mailcap" system) ("/usr/etc/mailcap" system) ("/usr/local/etc/mailcap" system))))) - ;; The ~/.mailcap entries will end up first in the resulting data. - (dolist (spec (reverse - (if (stringp path) - (split-string path path-separator t) - path))) - (let ((source (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 source)))) + (when (seq-some (lambda (f) + (file-has-changed-p (car f) 'mail-parse-mailcaps)) + path) + ;; Clear out all old data. + (setq mailcap--computed-mime-data nil) + ;; Add the Emacs-distributed defaults (which will be used as + ;; fallbacks). Do it this way instead of just copying the list, + ;; since entries are destructively modified. + (cl-loop for (major . minors) in mailcap-mime-data + do (cl-loop for (minor . entry) in minors + do (mailcap-add-mailcap-entry major minor entry))) + ;; The ~/.mailcap entries will end up first in the resulting data. + (dolist (spec (reverse + (if (stringp path) + (split-string path path-separator t) + path))) + (let ((source (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 source))))) (setq mailcap-parsed-p t))) (defun mailcap-parse-mailcap (fname &optional source) @@ -1065,6 +1068,15 @@ For instance, \"foo.png\" will result in \"image/png\"." (match-string 1 file-name) ""))) +;;;###autoload +(defun mailcap-mime-type-to-extension (mime-type) + "Return a file name extension based on a mime type. +For instance, `image/png' will result in `png'." + (intern (cadr (split-string (if (symbolp mime-type) + (symbol-name mime-type) + mime-type) + "/")))) + (defun mailcap-mime-types () "Return a list of MIME media types." (mailcap-parse-mimetypes) @@ -1075,7 +1087,7 @@ For instance, \"foo.png\" will result in \"image/png\"." (dolist (data mailcap--computed-mime-data) (dolist (info (cdr data)) (setq type (cdr (assq 'type (cdr info)))) - (unless (string-match-p "\\*" type) + (unless (string-search "*" type) (push type res)))) (nreverse res))))) @@ -1177,7 +1189,24 @@ See \"~/.mailcap\", `mailcap-mime-data' and related files and variables." (shell-quote-argument (convert-standard-filename file)) command nil t)) - (start-process-shell-command command nil command))) + ;; Handlers such as "gio open" and kde-open5 start viewer in background + ;; and exit immediately. Avoid `start-process' since it assumes + ;; :connection-type `pty' and kills children processes with SIGHUP + ;; when temporary terminal session is finished (Bug#44824). + ;; An alternative is `process-connection-type' let-bound to nil for + ;; `start-process-shell-command' call (with no chance to report failure). + (make-process + :name "mailcap-view-file" + :connection-type 'pipe + :buffer nil ; "*Messages*" may be suitable for debugging + :sentinel (lambda (proc event) + (when (and (memq (process-status proc) '(exit signal)) + (/= (process-exit-status proc) 0)) + (message + "Command %s: %s." + (mapconcat #'identity (process-command proc) " ") + (substring event 0 -1)))) + :command (list shell-file-name shell-command-switch command)))) (provide 'mailcap) diff --git a/lisp/net/mairix.el b/lisp/net/mairix.el index e1d35c2a85a..3feb089ad05 100644 --- a/lisp/net/mairix.el +++ b/lisp/net/mairix.el @@ -24,7 +24,7 @@ ;; This is an interface to the mairix mail search engine. Mairix is ;; written by Richard Curnow and is licensed under the GPL. See the -;; home page for details: +;; Mairix website for details: ;; ;; http://www.rpcurnow.force9.co.uk/mairix/ ;; @@ -422,7 +422,7 @@ with m:msgid of the current article and enabled threads." (while (string-match "[<>]" mid) (setq mid (replace-match "" t t mid))) ;; mairix somehow does not like '$' in message-id - (when (string-match "\\$" mid) + (when (string-search "$" mid) (setq mid (concat mid "="))) (while (string-match "\\$" mid) (setq mid (replace-match "=," t t mid))) diff --git a/lisp/net/net-utils.el b/lisp/net/net-utils.el index 90cca7d415c..6f44d9844ef 100644 --- a/lisp/net/net-utils.el +++ b/lisp/net/net-utils.el @@ -885,9 +885,9 @@ and `network-connection-service-alist', which see." :type '(repeat (cons string string))) (defcustom whois-guess-server t - "If non-nil then whois will try to deduce the appropriate whois -server from the query. If the query doesn't look like a domain or hostname -then the server named by `whois-server-name' is used." + "If non-nil, try to deduce the appropriate whois server from the query. +If the query doesn't look like a domain or hostname then the +server named by `whois-server-name' is used." :type 'boolean) (defun whois-get-tld (host) @@ -943,7 +943,7 @@ The port is deduced from `network-connection-service-alist'." ;; Using a derived mode gives us keymaps, hooks, etc. (define-derived-mode network-connection-mode comint-mode "Network-Connection" - "Major mode for interacting with the network-connection program.") + "Major mode for interacting with the `network-connection' program.") (defun network-connection-mode-setup (host service) (setq-local network-connection-host host) diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index e623dab26df..27ea713d0e5 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -610,7 +610,7 @@ This does NOT start the retrieval timers." (interactive) (let ((filename (read-string "Filename: " (concat feed ":_" - (replace-regexp-in-string + (string-replace " " "_" (newsticker--title item)) ".html")))) (with-temp-buffer @@ -2183,7 +2183,7 @@ FEED is a symbol!" (progn (when (y-or-n-p "Old newsticker cache file exists. Read it? ") (newsticker--cache-read-version1)) - (when (y-or-n-p (format "Delete old newsticker cache file? ")) + (when (y-or-n-p "Delete old newsticker cache file? ") (delete-file newsticker-cache-filename))) (dolist (f (append newsticker-url-list-defaults newsticker-url-list)) (newsticker--cache-read-feed (car f))))) diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index 1d9ee6db86c..b067b23f8ff 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -34,7 +34,7 @@ (defvar nsm-temporary-host-settings nil) (defgroup nsm nil - "Network Security Manager" + "Network Security Manager." :version "25.1" :group 'comm) @@ -79,8 +79,7 @@ option." (const :tag "Off" nil) (function :tag "Custom function"))) -(defcustom nsm-settings-file (expand-file-name "network-security.data" - user-emacs-directory) +(defcustom nsm-settings-file (locate-user-emacs-file "network-security.data") "The file the security manager settings will be stored in." :version "25.1" :type 'file) @@ -446,8 +445,8 @@ this check has no effect on GnuTLS >= 3.2.0. Reference: -[1]: Schneier, Bruce (1996). Applied Cryptography (Second ed.). John -Wiley & Sons. ISBN 0-471-11709-9. +[1]: Schneier, Bruce (1996). Applied Cryptography (Second ed.). +John Wiley & Sons. ISBN 0-471-11709-9. [2]: N. Mavrogiannopoulos, FSF (Apr 2015). \"GnuTLS NEWS -- History of user-visible changes.\" Version 3.4.0, `https://gitlab.com/gnutls/gnutls/blob/master/NEWS'" @@ -466,7 +465,7 @@ man-in-the-middle attacks. Reference: -GnuTLS authors (2018). \"GnuTLS Manual 4.3.3 Anonymous +GnuTLS authors (2018). \"GnuTLS Manual 4.3.3 Anonymous authentication\", `https://www.gnutls.org/manual/gnutls.html#Anonymous-authentication'" (let ((kx (plist-get status :key-exchange))) diff --git a/lisp/net/ntlm.el b/lisp/net/ntlm.el index 0450c80c2ec..0e0146df969 100644 --- a/lisp/net/ntlm.el +++ b/lisp/net/ntlm.el @@ -405,8 +405,8 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of (ntlm-md4hash password))) (defun ntlm-ascii2unicode (str len) - "Convert an ASCII string into a NT Unicode string, which is -little-endian utf16." + "Convert an ASCII string STR of length LEN into a NT Unicode string. +NT Unicode strings are little-endian utf16." ;; FIXME: Can't we use encode-coding-string with a `utf-16le' coding system? (let ((utf (make-string (* 2 len) 0)) (i 0) @@ -428,25 +428,24 @@ little-endian utf16." buf)) (defun ntlm-smb-passwd-hash (passwd) - "Return the SMB password hash string of 16 bytes long for the given password -string PASSWD. PASSWD is truncated to 14 bytes if longer." + "Return SMB password hash string of 16 bytes long for password string PASSWD. +PASSWD is truncated to 14 bytes if longer." (let ((len (min (length passwd) 14))) (ntlm-smb-des-e-p16 (concat (substring (upcase passwd) 0 len) ;fill top 14 bytes with passwd (make-string (- 15 len) 0))))) (defun ntlm-smb-owf-encrypt (passwd c8) - "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." + "Return response string of 24 bytes long for PASSWD based on 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 (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) - "Return a 24 bytes hashed string for a 21 bytes string P22 and a 8 bytes -string C8." + "Return 24 bytes hashed string for a 21 bytes string P22 and a 8 bytes string C8." (concat (ntlm-smb-hash c8 p22 t) ;hash first 8 bytes of p22 (ntlm-smb-hash c8 (substring p22 7) t) (ntlm-smb-hash c8 (substring p22 14) t))) @@ -460,8 +459,8 @@ string C8." (substring p15 7) t))) (defun ntlm-smb-hash (in key forw) - "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." + "Return hash string of length 8 for IN of length 8 and KEY of length 8. +FORW is t or nil." (let ((out (make-string 8 0)) (inb (make-string 64 0)) (keyb (make-string 64 0)) @@ -603,8 +602,8 @@ a string KEY of length 8. FORW is t or nil." [ 2 1 14 7 4 10 8 13 15 12 9 0 3 5 6 11]]]) (defsubst ntlm-string-permute (in perm n) - "Return a string of length N for a string IN and a permutation vector -PERM of size N. The length of IN should be height of PERM." + "Return string of length N for string IN and permutation vector PERM of size N. +The length of IN should be height of PERM." (let ((i 0) (out (make-string n 0))) (while (< i n) (aset out i (aref in (- (aref perm i) 1))) @@ -701,8 +700,8 @@ backward." (ntlm-string-permute rl ntlm-smb-perm6 64))) (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." + "Return 16 bytes MD4 hash of string PASSWD after converting it to Unicode. +PASSWD is truncated to 128 bytes if longer." (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))) diff --git a/lisp/net/pop3.el b/lisp/net/pop3.el index cb49f75c81d..a267ac319b6 100644 --- a/lisp/net/pop3.el +++ b/lisp/net/pop3.el @@ -551,8 +551,8 @@ Returns the process associated with the connection." (when result (let ((response (plist-get (cdr result) :greeting))) (setq pop3-timestamp - (substring response (or (string-match "<" response) 0) - (+ 1 (or (string-match ">" response) -1))))) + (substring response (or (string-search "<" response) 0) + (+ 1 (or (string-search ">" response) -1))))) (set-process-query-on-exit-flag (car result) nil) (erase-buffer) (car result))))) diff --git a/lisp/net/quickurl.el b/lisp/net/quickurl.el index 2574c8cb63e..7f147fa0ded 100644 --- a/lisp/net/quickurl.el +++ b/lisp/net/quickurl.el @@ -24,19 +24,19 @@ ;;; Commentary: ;; ;; This package provides a simple method of inserting a URL based on the -;; text at point in the current buffer. This is part of an on-going effort +;; text at point in the current buffer. This is part of an on-going effort ;; to increase the information I provide people while reducing the amount -;; of typing I need to do. No-doubt there are undiscovered Emacs packages +;; of typing I need to do. No-doubt there are undiscovered Emacs packages ;; out there that do all of this and do it better, feel free to point me to ;; them, in the mean time I'm having fun playing with Emacs Lisp. ;; ;; The URLs are stored in an external file as a list of either cons cells, -;; or lists. A cons cell entry looks like this: +;; or lists. A cons cell entry looks like this: ;; ;; (<Lookup> . <URL>) ;; ;; where <Lookup> is a string that acts as the keyword lookup and <URL> is -;; the URL associated with it. An example might be: +;; the URL associated with it. An example might be: ;; ;; ("GNU" . "https://www.gnu.org/") ;; @@ -45,8 +45,8 @@ ;; (<Lookup> <URL> <Comment>) ;; ;; where <Lookup> and <URL> are the same as with the cons cell and <Comment> -;; is any text you like that describes the URL. This description will be -;; used when presenting a list of URLS using `quickurl-list'. An example +;; is any text you like that describes the URL. This description will be +;; used when presenting a list of URLS using `quickurl-list'. An example ;; might be: ;; ;; ("FSF" "https://www.fsf.org/" "The Free Software Foundation") @@ -215,8 +215,8 @@ Note that this function is a setfable place." (defun quickurl-url-comment (url) "Get the comment from a URL. -If the URL has no comment an empty string is returned. Also note that this -function is a setfable place." +If the URL has no comment an empty string is returned. Also note +that this function is a setfable place." (declare (gv-setter (lambda (store) `(if (quickurl-url-commented-p ,url) @@ -284,7 +284,7 @@ It also restores point after the `read'." "Return URL associated with key LOOKUP. The lookup is done by looking in the alist `quickurl-urls' and the `cons' -for the URL is returned. The actual method used to look into the alist +for the URL is returned. The actual method used to look into the alist depends on the setting of the variable `quickurl-assoc-function'." (funcall quickurl-assoc-function lookup quickurl-urls)) diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index f11f36e8096..52d74a33945 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -4,7 +4,8 @@ ;; Author: Ryan Yeske <rcyeske@gmail.com> ;; Maintainers: Ryan Yeske <rcyeske@gmail.com>, -;; Leo Liu <sdl.web@gmail.com> +;; Leo Liu <sdl.web@gmail.com>, +;; Philip Kaludercic <philipk@posteo.net> ;; Keywords: comm ;; This file is part of GNU Emacs. @@ -60,9 +61,9 @@ (defcustom rcirc-server-alist (if (gnutls-available-p) - '(("irc.libera.chat" :channels ("#rcirc") + '(("irc.libera.chat" :channels ("#emacs" "#rcirc") :port 6697 :encryption tls)) - '(("irc.libera.chat" :channels ("#rcirc")))) + '(("irc.libera.chat" :channels ("#emacs" "#rcirc")))) "An alist of IRC connections to establish when running `rcirc'. Each element looks like (SERVER-NAME PARAMETERS). @@ -189,22 +190,24 @@ If nil, no maximum is applied." (defvar-local rcirc-low-priority-flag nil "Non-nil means activity in this buffer is considered low priority.") +(defvar-local rcirc-pending-requests '() + "List of pending requests. +See `rcirc-omit-unless-requested'.") + +(defcustom rcirc-omit-unless-requested '() + "List of commands to only be requested if preceded by a command. +For example, if \"TOPIC\" is added to this list, TOPIC commands +will only be displayed if `rcirc-cmd-TOPIC' was previously +invoked. Commands will only be hidden if `rcirc-omit-mode' is +enabled." + :version "28.1" + :type '(repeat string)) + (defcustom rcirc-omit-responses '("JOIN" "PART" "QUIT" "NICK") "Responses which will be hidden when `rcirc-omit-mode' is enabled." :type '(repeat string)) -(defcustom rcirc-omit-after-reconnect - '("JOIN" "TOPIC" "NAMES") - "Types of messages to hide right after reconnecting." - :type '(repeat string) - :version "28.1") - -(defvar-local rcirc-reconncting nil - "Non-nil means we have just reconnected. -This is used to hide the message types enumerated in -`rcirc-supress-after-reconnect'.") - (defvar-local rcirc-prompt-start-marker nil "Marker indicating the beginning of the message prompt.") @@ -215,11 +218,8 @@ Uninteresting lines are those whose responses are listed in `rcirc-omit-responses'." :lighter " Omit" (if rcirc-omit-mode - (progn - (add-to-invisibility-spec '(rcirc-omit . nil)) - (message "Rcirc-Omit mode enabled")) - (remove-from-invisibility-spec '(rcirc-omit . nil)) - (message "Rcirc-Omit mode disabled")) + (add-to-invisibility-spec '(rcirc-omit . nil)) + (remove-from-invisibility-spec '(rcirc-omit . nil))) (dolist (window (get-buffer-window-list (current-buffer))) (with-selected-window window (recenter (when (> (point) rcirc-prompt-start-marker) -1))))) @@ -413,6 +413,21 @@ will be killed." :version "28.1" :type 'function) +(defcustom rcirc-channel-filter #'identity + "Function applied to channels before displaying." + :version "28.1" + :type 'function) + +(defcustom rcirc-track-ignore-server-buffer-flag nil + "Non-nil means activities in the server buffer are not traced." + :version "28.1" + :type 'boolean) + +(defcustom rcirc-display-server-buffer t + "Non-nil means the server buffer should be shown on connecting." + :version "28.1" + :type 'boolean) + (defvar-local rcirc-nick nil "The nickname used for the current connection.") @@ -512,10 +527,12 @@ If ARG is non-nil, instead prompt for connection parameters." :channels) " ")) "[, ]+" t)) - (encryption (rcirc-prompt-for-encryption server-plist))) - (rcirc-connect server port nick user-name - rcirc-default-full-name - channels password encryption)) + (encryption (rcirc-prompt-for-encryption server-plist)) + (process (rcirc-connect server port nick user-name + rcirc-default-full-name + channels password encryption))) + (when rcirc-display-server-buffer + (pop-to-buffer-same-window (process-buffer process)))) ;; connect to servers in `rcirc-server-alist' (let (connected-servers) (dolist (c rcirc-server-alist) @@ -544,9 +561,11 @@ If ARG is non-nil, instead prompt for connection parameters." (setq connected p))) (if (not connected) (condition-case nil - (rcirc-connect server port nick user-name - full-name channels password encryption - server-alias) + (let ((process (rcirc-connect server port nick user-name + full-name channels password encryption + server-alias))) + (when rcirc-display-server-buffer + (pop-to-buffer-same-window (process-buffer process)))) (quit (message "Quit connecting to %s" (or server-alias server)))) (with-current-buffer (process-buffer connected) @@ -595,6 +614,8 @@ FULL-NAME STARTUP-CHANNELS PASSWORD ENCRYPTION SERVER-ALIAS). See `rcirc-connect' for more details on these variables.") (defvar-local rcirc-process nil "Network process for the current connection.") +(defvar-local rcirc-last-connect-time nil + "The last time the buffer was connected.") ;;; IRCv3 capability negotiation (https://ircv3.net/specs/extensions/capability-negotiation) (defvar rcirc-implemented-capabilities @@ -604,6 +625,16 @@ See `rcirc-connect' for more details on these variables.") "message-ids" ;https://ircv3.net/specs/extensions/message-ids "invite-notify" ;https://ircv3.net/specs/extensions/invite-notify "sasl" ;https://ircv3.net/specs/extensions/sasl-3.1 + "multi-prefix" ;https://ircv3.net/specs/extensions/multi-prefix + "standard-replies" ;https://ircv3.net/specs/extensions/standard-replies + ;; The following capabilities should be implemented as soon as + ;; their specifications are undrafted: + ;; + ;; "reply" ;https://ircv3.net/specs/client-tags/reply + ;; "react" ;https://ircv3.net/specs/client-tags/react + ;; "multiline" ;https://ircv3.net/specs/extensions/multiline + ;; "chathistory" ;https://ircv3.net/specs/extensions/chathistory + ;; "channel-rename" ;https://ircv3.net/specs/extensions/channel-rename ) "A list of capabilities that rcirc supports.") (defvar-local rcirc-requested-capabilities nil @@ -611,7 +642,7 @@ See `rcirc-connect' for more details on these variables.") (defvar-local rcirc-acked-capabilities nil "A list of capabilities that the server supports.") (defvar-local rcirc-finished-sasl t - "Check whether SASL authentication has completed") + "Check whether SASL authentication has completed.") (defun rcirc-get-server-method (server) "Return authentication method for SERVER." @@ -644,69 +675,61 @@ that are joined after authentication." (message "Connecting to %s..." (or server-alias server)) (let* ((inhibit-eol-conversion) (port-number (if port - (if (stringp port) - (string-to-number port) - port) - rcirc-default-port)) - (nick (or nick rcirc-default-nick)) - (user-name (or user-name rcirc-default-user-name)) - (full-name (or full-name rcirc-default-full-name)) - (startup-channels startup-channels) - (use-sasl (eq (rcirc-get-server-method server) 'sasl)) - (process (open-network-stream + (if (stringp port) + (string-to-number port) + port) + rcirc-default-port)) + (nick (or nick rcirc-default-nick)) + (user-name (or user-name rcirc-default-user-name)) + (full-name (or full-name rcirc-default-full-name)) + (startup-channels startup-channels) + + process) + + ;; Ensure any previous process is killed + (when-let ((old-process (get-process (or server-alias server)))) + (set-process-sentinel old-process #'ignore) + (delete-process process)) + + ;; Set up process + (setq process (open-network-stream (or server-alias server) nil server port-number - :type (or encryption 'plain)))) - ;; set up process + :type (or encryption 'plain) + :nowait t)) (set-process-coding-system process 'raw-text 'raw-text) - (switch-to-buffer (rcirc-generate-new-buffer-name process nil)) - (set-process-buffer process (current-buffer)) - (unless (eq major-mode 'rcirc-mode) - (rcirc-mode process nil)) - (set-process-sentinel process 'rcirc-sentinel) - (set-process-filter process 'rcirc-filter) - - (setq rcirc-connection-info - (list server port nick user-name full-name startup-channels - password encryption server-alias)) - (setq rcirc-process process) - (setq rcirc-server server) - (setq rcirc-server-name (or server-alias server)) ; Update when we get 001 response. - (setq rcirc-nick-table (make-hash-table :test 'equal)) - (setq rcirc-nick nick) - (setq rcirc-startup-channels startup-channels) - (setq rcirc-last-server-message-time (current-time)) - - (setq rcirc-connecting t) - - (add-hook 'auto-save-hook 'rcirc-log-write) - (when use-sasl - (rcirc-send-string process "CAP REQ sasl")) - - (when use-sasl - (setq-local rcirc-finished-sasl nil)) - ;; identify - (dolist (cap rcirc-implemented-capabilities) - (rcirc-send-string process "CAP" "REQ" : cap) - (push cap rcirc-requested-capabilities)) - (unless (zerop (length password)) - (rcirc-send-string process "PASS" password)) - (rcirc-send-string process "NICK" nick) - (rcirc-send-string process "USER" user-name "0" "*" : full-name) - ;; Setup sasl, and initiate authentication. - (when (and rcirc-auto-authenticate-flag - use-sasl) - (rcirc-send-string process "AUTHENTICATE" "PLAIN")) - - ;; setup ping timer if necessary - (unless rcirc-keepalive-timer - (setq rcirc-keepalive-timer - (run-at-time 0 (/ rcirc-timeout-seconds 2) 'rcirc-keepalive))) - - (message "Connecting to %s...done" (or server-alias server)) - (setq mode-line-process nil) - - ;; return process object - process))) + (with-current-buffer (get-buffer-create (rcirc-generate-new-buffer-name process nil)) + (set-process-buffer process (current-buffer)) + (unless (eq major-mode 'rcirc-mode) + (rcirc-mode process nil)) + (set-process-sentinel process #'rcirc-sentinel) + (set-process-filter process #'rcirc-filter) + + (setq rcirc-connection-info + (list server port nick user-name full-name startup-channels + password encryption server-alias)) + (setq rcirc-process process) + (setq rcirc-server server) + (setq rcirc-server-name (or server-alias server)) ; Update when we get 001 response. + (setq rcirc-nick-table (make-hash-table :test 'equal)) + (setq rcirc-nick nick) + (setq rcirc-startup-channels startup-channels) + (setq rcirc-last-server-message-time (current-time)) + (setq rcirc-last-connect-time (current-time)) + + ;; Check if the immediate process state + (sit-for .1) + (cond + ((eq (process-status process) 'failed) + (setq mode-line-process ":disconnected") + (setq rcirc-connecting nil)) + ((eq (process-status process) 'connect) + (setq mode-line-process ":connecting") + (setq rcirc-connecting t))) + + (add-hook 'auto-save-hook #'rcirc-log-write) + + ;; return process object + process)))) (defmacro with-rcirc-process-buffer (process &rest body) "Evaluate BODY in the buffer of PROCESS." @@ -795,31 +818,114 @@ When 0, do not auto-reconnect." :version "25.1" :type 'integer) -(defvar-local rcirc-last-connect-time nil - "The last time the buffer was connected.") +(defcustom rcirc-reconnect-attempts 3 + "Number of times a reconnection should be attempted." + :version "28.1" + :type 'integer) + +(defvar-local rcirc-failed-attempts 0 + "Number of times reconnecting has failed.") + +(defvar-local rcirc-reconnection-timer nil + "Timer used for reconnecting.") + +(defun rcirc-reconnect (process &optional quiet) + "Attempt to reconnect connection to PROCESS. +If QUIET is non-nil, no not emit a message." + (with-rcirc-process-buffer process + (catch 'exit + (if (rcirc--connection-open-p process) + (throw 'exit (or quiet (message "Server process is alive"))) + (delete-process process)) + (let ((conn-info rcirc-connection-info)) + (setf (nth 5 conn-info) + (cl-remove-if-not #'rcirc-channel-p + (mapcar #'car rcirc-buffer-alist))) + (dolist (buffer (mapcar #'cdr rcirc-buffer-alist)) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (setq mode-line-process ":connecting")))) + (let ((nprocess (apply #'rcirc-connect conn-info))) + (when (and (< rcirc-failed-attempts rcirc-reconnect-attempts) + (eq (process-status nprocess) 'failed)) + (setq rcirc-failed-attempts (1+ rcirc-failed-attempts)) + (rcirc-print nprocess "*rcirc*" "ERROR" nil + (format "Failed to reconnect (%d/%d)..." + rcirc-failed-attempts + rcirc-reconnect-attempts)) + (setq rcirc-reconnection-timer + (run-at-time rcirc-reconnect-delay nil + #'rcirc-reconnect process t)))))))) (defun rcirc-sentinel (process sentinel) - "Called when PROCESS receives SENTINEL." - (let ((sentinel (replace-regexp-in-string "\n" "" sentinel))) + "Called on a change of the state of PROCESS. +SENTINEL describes the change in form of a string." + (let ((status (process-status process))) (rcirc-debug process (format "SENTINEL: %S %S\n" process sentinel)) (with-rcirc-process-buffer process - (dolist (buffer (cons nil (mapcar 'cdr rcirc-buffer-alist))) - (with-current-buffer (or buffer (current-buffer)) - (rcirc-print process "rcirc.el" "ERROR" rcirc-target - (format "%s: %s (%S)" - (process-name process) - sentinel - (process-status process)) - (not rcirc-target)) - (rcirc-disconnect-buffer))) - (when (and (string= sentinel "deleted") - (< 0 rcirc-reconnect-delay)) + (cond + ((eq status 'open) + (let* ((server (nth 0 rcirc-connection-info)) + (user-name (nth 3 rcirc-connection-info)) + (full-name (nth 4 rcirc-connection-info)) + (password (nth 6 rcirc-connection-info)) + (server-alias (nth 8 rcirc-connection-info)) + (use-sasl (eq (rcirc-get-server-method server) 'sasl))) + + ;; Prepare SASL authentication + (when use-sasl + (rcirc-send-string process "CAP REQ sasl") + (setq-local rcirc-finished-sasl nil)) + + ;; Capability negotiation + (dolist (cap rcirc-implemented-capabilities) + (rcirc-send-string process "CAP" "REQ" : cap) + (push cap rcirc-requested-capabilities)) + + ;; Identify user + (unless (zerop (length password)) + (rcirc-send-string process "PASS" password)) + (rcirc-send-string process "NICK" rcirc-nick) + (rcirc-send-string process "USER" user-name "0" "*" : full-name) + + ;; Setup sasl, and initiate authentication. + (when (and rcirc-auto-authenticate-flag + use-sasl) + (rcirc-send-string process "AUTHENTICATE" "PLAIN")) + + ;; Setup ping timer if necessary + (unless rcirc-keepalive-timer + (setq rcirc-keepalive-timer + (run-at-time 0 (/ rcirc-timeout-seconds 2) #'rcirc-keepalive))) + + ;; Reset previous reconnection attempts + (setq rcirc-failed-attempts 0) + (when rcirc-reconnection-timer + (cancel-timer rcirc-reconnection-timer) + (setq rcirc-reconnection-timer nil)) + + (message "Connecting to %s...done" (or server-alias server)) + (dolist (buffer (cons nil (mapcar 'cdr rcirc-buffer-alist))) + (with-current-buffer (or buffer (current-buffer)) + (setq mode-line-process nil))))) + ((eq status 'closed) (let ((now (current-time))) - (when (or (null rcirc-last-connect-time) - (time-less-p rcirc-reconnect-delay - (time-subtract now rcirc-last-connect-time))) - (setq rcirc-last-connect-time now) - (rcirc-cmd-reconnect nil)))) + (with-rcirc-process-buffer process + (when (and (< 0 rcirc-reconnect-delay) + (time-less-p rcirc-reconnect-delay + (time-subtract now rcirc-last-connect-time))) + (setq rcirc-last-connect-time now) + (rcirc-reconnect process))))) + ((eq status 'failed) + (dolist (buffer (cons nil (mapcar 'cdr rcirc-buffer-alist))) + (with-current-buffer (or buffer (current-buffer)) + (rcirc-print process "*rcirc*" "ERROR" rcirc-target + (format "%s: %s (%S)" + (process-name process) + sentinel + (process-status process)) + (not rcirc-target)) + (rcirc-disconnect-buffer))))) (run-hook-with-args 'rcirc-sentinel-functions process sentinel)))) (defun rcirc-disconnect-buffer (&optional buffer) @@ -879,7 +985,7 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.") (condition-case err (rcirc-process-server-response-1 process text) (error - (rcirc-print process "RCIRC" "ERROR" nil + (rcirc-print process "*rcirc*" "ERROR" nil (format "\"%s\" %s" text err) t))) (rcirc-process-server-response-1 process text))) @@ -1054,7 +1160,7 @@ With no argument or nil as argument, use the current buffer." (let ((buffer (or buffer (and (buffer-live-p rcirc-server-buffer) rcirc-server-buffer)))) (if buffer - (with-current-buffer buffer rcirc-process) + (buffer-local-value 'rcirc-process buffer) rcirc-process))) (defun rcirc-server-name (process) @@ -1258,7 +1364,8 @@ Each element looks like (FILENAME . TEXT).") This number is independent of the number of lines in the buffer.") (defun rcirc-mode (process target) - "Major mode for IRC channel buffers. + "Initialize an IRC buffer for writing with TARGET. +PROCESS is the process object used for communication. \\{rcirc-mode-map}" ;; FIXME: Use define-derived-mode. @@ -1281,7 +1388,6 @@ This number is independent of the number of lines in the buffer.") (setq rcirc-last-post-time (current-time)) (setq-local fill-paragraph-function 'rcirc-fill-paragraph) (setq rcirc-current-line 0) - (setq rcirc-last-connect-time (current-time)) (use-hard-newlines t) @@ -1320,8 +1426,7 @@ This number is independent of the number of lines in the buffer.") (when target ; skip server buffer (let ((buffer (current-buffer))) (with-rcirc-process-buffer process - (setq rcirc-buffer-alist (cons (cons target buffer) - rcirc-buffer-alist)))) + (push (cons target buffer) rcirc-buffer-alist))) (rcirc-update-short-buffer-names)) (add-hook 'completion-at-point-functions @@ -1464,10 +1569,10 @@ Create the buffer if it doesn't exist." (rcirc-generate-new-buffer-name process target)))) (with-current-buffer new-buffer (unless (eq major-mode 'rcirc-mode) - (rcirc-mode process target))) - (setq mode-line-process nil) - (rcirc-put-nick-channel process (rcirc-nick process) target - rcirc-current-line) + (rcirc-mode process target)) + (setq mode-line-process nil)) + (rcirc-put-nick-channel process (rcirc-nick process) target + rcirc-current-line) new-buffer))))) (defun rcirc-send-input () @@ -1522,6 +1627,11 @@ The argument JUSTIFY is passed on to `fill-region'." (defun rcirc-process-message (line) "Process LINE as a message to be sent." + (when (and (null rcirc-target) + (string-match + (rx bos (group (+? nonl)) "@" (+ nonl) eos) + (buffer-name))) + (setq rcirc-target (match-string 1 (buffer-name)))) (if (not rcirc-target) (message "Not joined (no target)") (delete-region rcirc-prompt-end-marker (point)) @@ -1625,6 +1735,9 @@ extracted." ("ACTION" . "[%N %m]") ("COMMAND" . "%m") ("ERROR" . "%fw!!! %m") + ("FAIL" . "(%fwFAIL%f-) %m") + ("WARN" . "(%fwWARN%f-) %m") + ("NOTE" . "(%fwNOTE%f-) %m") (t . "%fp*** %fs%n %r %m")) "An alist of formats used for printing responses. The format is looked up using the response-type as a key; @@ -1742,8 +1855,9 @@ Returns nil if the information is not recorded. PROCESS is the process object for the current connection." (let ((chanbuf (rcirc-get-buffer process target))) (when chanbuf - (cdr (assoc-string nick (with-current-buffer chanbuf - rcirc-recent-quit-alist)))))) + (cdr (assoc-string nick (buffer-local-value + 'rcirc-recent-quit-alist + chanbuf)))))) (defun rcirc-last-line (process nick target) "Return the line from the last activity from NICK in TARGET. @@ -1857,12 +1971,15 @@ connection." ;; make text omittable (let ((last-activity-lines (rcirc-elapsed-lines process sender target))) (if (and (not (string= (rcirc-nick process) sender)) - (or (member response rcirc-omit-responses) - (if (member response rcirc-omit-after-reconnect) - rcirc-reconncting - (setq rcirc-reconncting nil))) - (or (not last-activity-lines) - (< rcirc-omit-threshold last-activity-lines))) + (or (member response rcirc-omit-responses) + (and (member response rcirc-omit-unless-requested) + (if (member response rcirc-pending-requests) + (ignore (setq rcirc-pending-requests + (delete response rcirc-pending-requests))) + t))) + (or (member response rcirc-omit-unless-requested) + (not last-activity-lines) + (< rcirc-omit-threshold last-activity-lines))) (put-text-property (point-min) (point-max) 'invisible 'rcirc-omit) ;; otherwise increment the line count @@ -2008,7 +2125,8 @@ PROCESS is the process object for the current connection." "Return the nick from USER. Remove any non-nick junk." (save-match-data (if (string-match (concat "^[" rcirc-nick-prefix-chars - "]?\\([^! ]+\\)!?") (or user "")) + "]*\\([^! ]+\\)!?") + (or user "")) (match-string 1 user) user))) @@ -2119,6 +2237,11 @@ This function does not alter the INPUT string." map) "Keymap for rcirc track minor mode.") +(defcustom rcirc-track-abbrevate-flag t + "Non-nil means `rcirc-track-minor-mode' should abbreviate names." + :version "28.1" + :type 'boolean) + ;;;###autoload (define-minor-mode rcirc-track-minor-mode "Global minor mode for tracking activity in rcirc buffers." @@ -2176,7 +2299,7 @@ This function does not alter the INPUT string." "Bury all RCIRC buffers." (interactive) (dolist (buf (buffer-list)) - (when (eq 'rcirc-mode (with-current-buffer buf major-mode)) + (when (eq 'rcirc-mode (buffer-local-value 'major-mode buf)) (bury-buffer buf) ; buffers not shown (quit-windows-on buf)))) ; buffers shown in a window @@ -2216,13 +2339,15 @@ activity. Only run if the buffer is not visible and (with-current-buffer buffer (let ((old-activity rcirc-activity) (old-types rcirc-activity-types)) - (when (not (get-buffer-window (current-buffer) t)) + (when (and (not (get-buffer-window (current-buffer) t)) + (not (and rcirc-track-ignore-server-buffer-flag + (eq rcirc-server-buffer (current-buffer))))) (setq rcirc-activity (sort (if (memq (current-buffer) rcirc-activity) rcirc-activity (cons (current-buffer) rcirc-activity)) (lambda (b1 b2) - (let ((t1 (with-current-buffer b1 rcirc-last-post-time)) - (t2 (with-current-buffer b2 rcirc-last-post-time))) + (let ((t1 (buffer-local-value 'rcirc-last-post-time b1)) + (t2 (buffer-local-value 'rcirc-last-post-time b2))) (time-less-p t2 t1))))) (cl-pushnew type rcirc-activity-types) (unless (and (equal rcirc-activity old-activity) @@ -2299,7 +2424,12 @@ activity. Only run if the buffer is not visible and (defun rcirc-short-buffer-name (buffer) "Return a short name for BUFFER to use in the mode line indicator." (with-current-buffer buffer - (or rcirc-short-buffer-name (buffer-name)))) + (funcall rcirc-channel-filter + (replace-regexp-in-string + "@.*?\\'" "" + (or (and rcirc-track-abbrevate-flag + rcirc-short-buffer-name) + (buffer-name)))))) (defun rcirc-visible-buffers () "Return a list of the visible buffers that are in `rcirc-mode'." @@ -2408,7 +2538,7 @@ prefix with another element in PAIRS." (when (and (listp x) (listp (cadr x))) (setcdr x (if (> (length (cdr x)) 1) (rcirc-make-trees (cdr x)) - (setcdr x (list (cl-cdadr x))))))) + (setcdr x (list (cdadr x))))))) alist))) ;;; /commands these are called with 3 args: PROCESS, TARGET, which is @@ -2441,23 +2571,24 @@ that, an interactive form can specified." (insert "\\(.*?\\)") (insert "[[:space:]]*\\'") (buffer-string))) - (argument (gensym)) + (argument (make-symbol "arglist")) documentation interactive-spec) (when (stringp (car body)) (setq documentation (pop body))) (when (eq (car-safe (car-safe body)) 'interactive) - (setq interactive-spec (cdr (pop body)))) + (setq interactive-spec (cadr (pop body)))) `(progn (defun ,fn-name (,argument &optional process target) ,(concat documentation "\n\nNote: If PROCESS or TARGET are nil, the values given" "\nby `rcirc-buffer-process' and `rcirc-target' will be used.") - (interactive (list ,@interactive-spec)) + (interactive ,interactive-spec) (unless (if (listp ,argument) (<= ,required (length ,argument) ,total) (string-match ,regexp ,argument)) - (user-error "Malformed input (%s): %S" ',command ',argument)) + (user-error "Malformed input (%s): %S" ',command ,argument)) + (push ,(upcase (symbol-name command)) rcirc-pending-requests) (let ((process (or process (rcirc-buffer-process))) (target (or target rcirc-target))) (ignore target process) @@ -2533,18 +2664,8 @@ to `rcirc-default-part-reason'." (rcirc-define-command reconnect () "Reconnect to current server." (interactive "i") - (with-rcirc-server-buffer - (cond - (rcirc-connecting (message "Already connecting")) - ((process-live-p process) (message "Server process is alive")) - (t (let ((conn-info rcirc-connection-info)) - (setf (nth 5 conn-info) - (cl-remove-if-not #'rcirc-channel-p - (mapcar #'car rcirc-buffer-alist))) - (dolist (buf (nth 5 conn-info)) - (with-current-buffer (cdr (assoc buf rcirc-buffer-alist)) - (setq rcirc-reconncting t))) - (apply #'rcirc-connect conn-info)))))) + (setq rcirc-failed-attempts 0) + (rcirc-reconnect process)) (rcirc-define-command nick (nick) "Change nick to NICK." @@ -2564,8 +2685,8 @@ With a prefix arg, prompt for new topic." (interactive (list (and current-prefix-arg (read-string "List names in channel: ")))) (if (> (length topic) 0) - (rcirc-send-string process "TOPIC" : topic) - (rcirc-send-string process "TOPIC"))) + (rcirc-send-string process "TOPIC" target : topic) + (rcirc-send-string process "TOPIC" target))) (rcirc-define-command whois (nick) "Request information from server about NICK." @@ -2706,24 +2827,9 @@ keywords when no KEYWORD is given." string)) (defvar rcirc-url-regexp - (concat - "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|" - "nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)" - "\\(//[-a-z0-9_.]+:[0-9]*\\)?" - (if (string-match "[[:digit:]]" "1") ;; Support POSIX? - (let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]") - (punct "!?:;.,")) - (concat - "\\(?:" - ;; Match paired parentheses, e.g. in Wikipedia URLs: - "[" chars punct "]+" "(" "[" chars punct "]+" ")" "[" chars "]" - "\\|" - "[" chars punct "]+" "[" chars "]" - "\\)")) - (concat ;; XEmacs 21.4 doesn't support POSIX. - "\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+" - "\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)")) - "\\)") + (eval-when-compile + (require 'browse-url) + browse-url-button-regexp) "Regexp matching URLs. Set to nil to disable URL features in rcirc.") ;; cf cl-remove-if-not @@ -3046,11 +3152,11 @@ connection." ;; already open buffer (after getting kicked e.g.) (setq mode-line-process nil)) - (rcirc-print process sender "JOIN" channel "") + (rcirc-print process sender "JOIN" (funcall rcirc-channel-filter channel) "") ;; print in private chat buffer if it exists (when (rcirc-get-buffer (rcirc-buffer-process) sender) - (rcirc-print process sender "JOIN" sender channel)))) + (rcirc-print process sender "JOIN" sender (funcall rcirc-channel-filter channel))))) ;; PART and KICK are handled the same way (defun rcirc-handler-PART-or-KICK (process _response channel _sender nick _args) @@ -3079,10 +3185,10 @@ PROCESS is the process object for the current connection." (let* ((channel (car args)) (reason (cadr args)) (message (concat channel " " reason))) - (rcirc-print process sender "PART" channel message) + (rcirc-print process sender "PART" (funcall rcirc-channel-filter channel) message) ;; print in private chat buffer if it exists (when (rcirc-get-buffer (rcirc-buffer-process) sender) - (rcirc-print process sender "PART" sender message)) + (rcirc-print process sender "PART" (funcall rcirc-channel-filter channel) message)) (rcirc-handler-PART-or-KICK process "PART" channel sender sender reason))) @@ -3094,7 +3200,7 @@ PROCESS is the process object for the current connection." (nick (cadr args)) (reason (nth 2 args)) (message (concat nick " " channel " " reason))) - (rcirc-print process sender "KICK" channel message t) + (rcirc-print process sender "KICK" (funcall rcirc-channel-filter channel) message t) ;; print in private chat buffer if it exists (when (rcirc-get-buffer (rcirc-buffer-process) nick) (rcirc-print process sender "KICK" nick message)) @@ -3124,7 +3230,7 @@ PROCESS is the process object for the current connection." (rcirc-ignore-update-automatic sender) (mapc (lambda (channel) ;; broadcast quit message each channel - (rcirc-print process sender "QUIT" channel (apply 'concat args)) + (rcirc-print process sender "QUIT" (funcall rcirc-channel-filter channel) (apply 'concat args)) ;; record nick in quit table if they recently spoke (rcirc-maybe-remember-nick-quit process sender channel)) (rcirc-nick-channels process sender)) @@ -3145,13 +3251,16 @@ PROCESS is the process object for the current connection." ;; print message to nick's channels (dolist (target channels) (rcirc-print process sender "NICK" target new-nick)) - ;; update private chat buffer, if it exists - (let ((chat-buffer (rcirc-get-buffer process old-nick))) - (when chat-buffer - (with-current-buffer chat-buffer - (rcirc-print process sender "NICK" old-nick new-nick) - (setq rcirc-target new-nick) - (rename-buffer (rcirc-generate-new-buffer-name process new-nick))))) + ;; update chat buffer, if it exists + (when-let ((chat-buffer (rcirc-get-buffer process old-nick))) + (with-current-buffer chat-buffer + (rcirc-print process sender "NICK" old-nick new-nick) + (setq rcirc-target new-nick) + (rename-buffer (rcirc-generate-new-buffer-name process new-nick))) + (setf rcirc-buffer-alist + (cons (cons new-nick chat-buffer) + (delq (assoc-string old-nick rcirc-buffer-alist t) + rcirc-buffer-alist)))) ;; remove old nick and add new one (with-rcirc-process-buffer process (let ((v (gethash old-nick rcirc-nick-table))) @@ -3234,7 +3343,7 @@ RFC1459." (with-current-buffer buffer (let ((setter (nth 2 args)) (time (current-time-string - (string-to-number (cl-cadddr args))))) + (string-to-number (cadddr args))))) (rcirc-print process sender "TOPIC" (cadr args) (format "%s (%s on %s)" rcirc-topic setter time)))))) @@ -3344,7 +3453,7 @@ Passwords are stored in `rcirc-authinfo' (which see)." (server (car i)) (nick (nth 2 i)) (method (cadr i)) - (args (cl-cdddr i))) + (args (cdddr i))) (when (and (string-match server rcirc-server)) (if (and (memq method '(nickserv chanserv bitlbee)) (string-match nick rcirc-nick)) @@ -3381,6 +3490,8 @@ process object for the current connection." (let ((self (buffer-local-value 'rcirc-nick rcirc-process)) (target (car args)) (chan (cadr args))) + ;; `rcirc-channel-filter' is not used here because joining + ;; requires an unfiltered name. (if (string= target self) (rcirc-print process sender "INVITE" nil (format "%s invited you to %s" @@ -3451,7 +3562,7 @@ is the process object for the current connection." (let ((subcmd (cadr args))) (dolist (cap (cddr args)) (cond ((string= subcmd "ACK") - (push cap rcirc-acked-capabilities) + (push (intern (downcase cap)) rcirc-acked-capabilities) (setq rcirc-requested-capabilities (delete cap rcirc-requested-capabilities))) ((string= subcmd "NAK") @@ -3525,13 +3636,36 @@ PROCESS is the process object for the current connection." "\0" (rcirc-get-server-password rcirc-server))))) (defun rcirc-handler-900 (process sender args _text) - "Respond to a successful authentication response." + "Respond to a successful authentication response. +SENDER is passed on to `rcirc-handler-generic'. PROCESS is the +process object for the current connection." (rcirc-handler-generic process "900" sender args nil) (when (not rcirc-finished-sasl) (setq-local rcirc-finished-sasl t) (rcirc-send-string process "CAP" "END")) (rcirc-join-channels-post-auth process)) +(defun rcirc-handler-FAIL (process _sender args _text) + "Display a FAIL message, as indicated by ARGS. +PROCESS is the process object for the current connection." + (rcirc-print process nil "FAIL" nil + (mapconcat #'identity args " ") + t)) + +(defun rcirc-handler-WARN (process _sender args _text) + "Display a WARN message, as indicated by ARGS. +PROCESS is the process object for the current connection." + (rcirc-print process nil "WARN" nil + (mapconcat #'identity args " ") + t)) + +(defun rcirc-handler-NOTE (process _sender args _text) + "Display a NOTE message, as indicated by ARGS. +PROCESS is the process object for the current connection." + (rcirc-print process nil "NOTE" nil + (mapconcat #'identity args " ") + t)) + (defgroup rcirc-faces nil "Faces for rcirc." diff --git a/lisp/net/rlogin.el b/lisp/net/rlogin.el index 3136e53b80b..a7001c1310e 100644 --- a/lisp/net/rlogin.el +++ b/lisp/net/rlogin.el @@ -238,8 +238,8 @@ ange-ftp. If called as a function, give it no argument. If called with a negative prefix argument, disable directory tracking entirely. -If called with a positive, numeric prefix argument, e.g. -`\\[universal-argument] 1 M-x rlogin-directory-tracking-mode', +If called with a positive, numeric prefix argument, for example +\\[universal-argument] 1 \\[rlogin-directory-tracking-mode], then do directory tracking but assume the remote filesystem is the same as the local system. This only works in general if the remote machine and the local one share the same directories (e.g. through NFS)." diff --git a/lisp/net/sasl-cram.el b/lisp/net/sasl-cram.el index 4022a35b391..2427f4976e3 100644 --- a/lisp/net/sasl-cram.el +++ b/lisp/net/sasl-cram.el @@ -24,6 +24,8 @@ ;;; Commentary: +;;; Code: + (require 'sasl) (require 'hmac-md5) diff --git a/lisp/net/sasl-digest.el b/lisp/net/sasl-digest.el index 5afc195d4b4..3696f526b5d 100644 --- a/lisp/net/sasl-digest.el +++ b/lisp/net/sasl-digest.el @@ -29,9 +29,9 @@ ;; It is caller's responsibility to base64-decode challenges and ;; base64-encode responses in IMAP4 AUTHENTICATE command. ;; -;; Passphrase should be longer than 16 bytes. (See RFC 2195) +;; Passphrase should be longer than 16 bytes. (See RFC 2195) -;;; Commentary: +;;; Code: (require 'sasl) (require 'hmac-md5) diff --git a/lisp/net/sasl-ntlm.el b/lisp/net/sasl-ntlm.el index dfb7e713302..9a5bba5b292 100644 --- a/lisp/net/sasl-ntlm.el +++ b/lisp/net/sasl-ntlm.el @@ -37,8 +37,8 @@ '(ignore ;nothing to do before making sasl-ntlm-request ;authentication request sasl-ntlm-response) ;response to challenge - "A list of functions to be called in sequence for the NTLM -authentication steps. They are called by `sasl-next-step'.") + "List of functions to call in sequence for the NTLM authentication steps. +They are called by `sasl-next-step'.") (defun sasl-ntlm-request (client _step) "SASL step function to generate a NTLM authentication request to the server. diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el index 4102b9d322a..4217c219ad9 100644 --- a/lisp/net/secrets.el +++ b/lisp/net/secrets.el @@ -159,7 +159,7 @@ "Whether there is a daemon offering the Secret Service API.") (defvar secrets-debug nil - "Write debug messages") + "Write debug messages.") (defconst secrets-service "org.freedesktop.secrets" "The D-Bus name used to talk to Secret Service.") diff --git a/lisp/net/shr-color.el b/lisp/net/shr-color.el index eb78a259a8c..aa92c365f87 100644 --- a/lisp/net/shr-color.el +++ b/lisp/net/shr-color.el @@ -30,7 +30,7 @@ (eval-when-compile (require 'cl-lib)) (defgroup shr-color nil - "Simple HTML Renderer colors" + "Simple HTML Renderer colors." :group 'shr) (defcustom shr-color-visible-luminance-min 40 diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 85d81b6bbcc..71c18ff9947 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -43,7 +43,7 @@ (require 'text-property-search) (defgroup shr nil - "Simple HTML Renderer" + "Simple HTML Renderer." :version "25.1" :group 'web) @@ -247,23 +247,21 @@ and other things: (defvar shr-target-id nil "Target fragment identifier anchor.") -(defvar shr-map - (let ((map (make-sparse-keymap))) - (define-key map "a" #'shr-show-alt-text) - (define-key map "i" #'shr-browse-image) - (define-key map "z" #'shr-zoom-image) - (define-key map [?\t] #'shr-next-link) - (define-key map [?\M-\t] #'shr-previous-link) - (define-key map [follow-link] 'mouse-face) - (define-key map [mouse-2] #'shr-browse-url) - (define-key map [C-down-mouse-1] #'shr-mouse-browse-url-new-window) - (define-key map "I" #'shr-insert-image) - (define-key map "w" #'shr-maybe-probe-and-copy-url) - (define-key map "u" #'shr-maybe-probe-and-copy-url) - (define-key map "v" #'shr-browse-url) - (define-key map "O" #'shr-save-contents) - (define-key map "\r" #'shr-browse-url) - map)) +(defvar-keymap shr-map + "a" #'shr-show-alt-text + "i" #'shr-browse-image + "z" #'shr-zoom-image + [?\t] #'shr-next-link + [?\M-\t] #'shr-previous-link + [follow-link] 'mouse-face + [mouse-2] #'shr-browse-url + [C-down-mouse-1] #'shr-mouse-browse-url-new-window + "I" #'shr-insert-image + "w" #'shr-maybe-probe-and-copy-url + "u" #'shr-maybe-probe-and-copy-url + "v" #'shr-browse-url + "O" #'shr-save-contents + "\r" #'shr-browse-url) (defvar shr-image-map (let ((map (copy-keymap shr-map))) @@ -1574,15 +1572,14 @@ ones, in case fg and bg are nil." (shr-urlify (or shr-start start) (shr-expand-url url) title)))) (defun shr-tag-abbr (dom) - (when-let* ((title (dom-attr dom 'title)) - (start (point))) + (let ((title (dom-attr dom 'title)) + (start (point))) (shr-generic dom) (shr-add-font start (point) 'shr-abbreviation) - (add-text-properties - start (point) - (list - 'help-echo title - 'mouse-face 'highlight)))) + (when title + (add-text-properties start (point) + (list 'help-echo title + 'mouse-face 'highlight))))) (defun shr-tag-acronym (dom) ;; `acronym' is deprecated in favor of `abbr'. @@ -1629,6 +1626,14 @@ url if no type is specified. The value should be a float in the range 0.0 to :version "24.4" :type '(alist :key-type regexp :value-type float)) +(defcustom shr-use-xwidgets-for-media nil + "If non-nil, use xwidgets to display video and audio elements. +This also depends on Emacs being built with xwidgets capability. +Note that this is experimental, and may lead to instability on +some platforms." + :type 'boolean + :version "29.1") + (defun shr--get-media-pref (elem) "Determine the preference for ELEM. The preference is a float determined from `shr-prefer-media-type'." @@ -1665,16 +1670,39 @@ The preference is a float determined from `shr-prefer-media-type'." pref (cdr ret))))))))) (cons url pref)) +(declare-function xwidget-webkit-execute-script "xwidget.c" + (xwidget script &optional callback)) + (defun shr-tag-video (dom) (let ((image (dom-attr dom 'poster)) (url (dom-attr dom 'src)) (start (point))) (unless url (setq url (car (shr--extract-best-source dom)))) - (if (> (length image) 0) - (shr-indirect-call 'img nil image) - (shr-insert " [video] ")) - (shr-urlify start (shr-expand-url url)))) + (if (and shr-use-xwidgets-for-media + (fboundp 'make-xwidget)) + ;; Play the video. + (progn + (require 'xwidget) + (let ((widget (make-xwidget + 'webkit + "Video" + (truncate (* (window-pixel-width) 0.8)) + (truncate (* (window-pixel-width) 0.8 0.75))))) + (insert + (propertize + " [video] " + 'display (list 'xwidget :xwidget widget))) + (xwidget-webkit-execute-script + widget (format "document.body.innerHTML = %S;" + (format + "<style>body { margin: 0px; }</style><div style='background: black; height: 100%%; display: flex; align-items: center; justify-content: center;'><video autoplay loop muted controls style='max-width: 100%%; max-height: 100%%;'><source src=%S type='video/mp4\'></source></video></div>" + url))))) + ;; No xwidgets. + (if (> (length image) 0) + (shr-indirect-call 'img nil image) + (shr-insert " [video] ")) + (shr-urlify start (shr-expand-url url))))) (defun shr-tag-audio (dom) (let ((url (dom-attr dom 'src)) diff --git a/lisp/net/sieve-manage.el b/lisp/net/sieve-manage.el index 1f08a15e570..64544bcf154 100644 --- a/lisp/net/sieve-manage.el +++ b/lisp/net/sieve-manage.el @@ -410,7 +410,7 @@ If BUFFER is nil, the current buffer is used." (defun sieve-manage-capability (&optional name value buffer) "Check if capability NAME of server BUFFER match VALUE. -If it does, return the server value of NAME. If not returns nil. +If it does, return the server value of NAME. If not return nil. If VALUE is nil, do not check VALUE and return server value. If NAME is nil, return the full server list of capabilities." (with-current-buffer (or buffer (current-buffer)) diff --git a/lisp/net/sieve-mode.el b/lisp/net/sieve-mode.el index 0e8fdc0a905..70cebd30396 100644 --- a/lisp/net/sieve-mode.el +++ b/lisp/net/sieve-mode.el @@ -132,7 +132,7 @@ (modify-syntax-entry ?\} "){" st) (modify-syntax-entry ?\" "\"" st) st) - "Syntax table in use in sieve-mode buffers.") + "Syntax table in use in `sieve-mode' buffers.") ;; Key map definition diff --git a/lisp/net/sieve.el b/lisp/net/sieve.el index 6d571a0a30f..99bc0a7acd2 100644 --- a/lisp/net/sieve.el +++ b/lisp/net/sieve.el @@ -224,7 +224,7 @@ require \"fileinto\"; (substitute-command-keys "\\[sieve-upload]")))) (defmacro sieve-change-region (&rest body) - "Turns off sieve-region before executing BODY, then re-enables it after. + "Turn off sieve-region before executing BODY, then re-enables it after. Used to bracket operations which move point in the sieve-buffer." (declare (indent 0) (debug t)) `(progn diff --git a/lisp/net/snmp-mode.el b/lisp/net/snmp-mode.el index ae878ef3a51..10892ebf611 100644 --- a/lisp/net/snmp-mode.el +++ b/lisp/net/snmp-mode.el @@ -328,7 +328,7 @@ Tab indents for C code. Comments start with -- and end with newline or another --. Delete converts tabs to spaces as it moves back. \\{snmp-mode-map} -Turning on snmp-mode runs the hooks in `snmp-common-mode-hook', then +Turning on `snmp-mode' runs the hooks in `snmp-common-mode-hook', then `snmp-mode-hook'." (interactive) @@ -361,7 +361,7 @@ Tab indents for C code. Comments start with -- and end with newline or another --. Delete converts tabs to spaces as it moves back. \\{snmp-mode-map} -Turning on snmp-mode runs the hooks in `snmp-common-mode-hook', +Turning on `snmp-mode' runs the hooks in `snmp-common-mode-hook', then `snmpv2-mode-hook'." (interactive) diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index 821ef4af8e0..b4aed279819 100644 --- a/lisp/net/soap-client.el +++ b/lisp/net/soap-client.el @@ -8,7 +8,7 @@ ;; Version: 3.2.0 ;; Keywords: soap, web-services, comm, hypermedia ;; Package: soap-client -;; Homepage: https://github.com/alex-hhh/emacs-soap-client +;; URL: https://github.com/alex-hhh/emacs-soap-client ;; Package-Requires: ((cl-lib "0.6.1")) ;;FIXME: Put in `Package-Requires:' the Emacs version we expect. @@ -659,7 +659,7 @@ representing leap seconds." (if second (if second-fraction (let* ((second-fraction-significand - (replace-regexp-in-string "\\." "" second-fraction)) + (string-replace "." "" second-fraction)) (hertz (expt 10 (length second-fraction-significand))) (ticks (+ (* hertz (string-to-number second)) @@ -860,7 +860,7 @@ contains a reference, retrieve the type of the reference." (if complex-type (setq type (soap-xs-parse-complex-type (car complex-type))) ;; else - (error "Soap-xs-parse-element: missing type or ref")))))) + (error "soap-xs-parse-element: Missing type or ref")))))) (make-soap-xs-element :name name ;; Use the full namespace name for now, we will @@ -1938,7 +1938,7 @@ This is a specialization of `soap-decode-type' for (e-name (soap-xs-element-name element)) ;; Heuristic: guess if we need to decode using local ;; namespaces. - (use-fq-names (string-match ":" (symbol-name (car node)))) + (use-fq-names (string-search ":" (symbol-name (car node)))) (children (if e-name (if use-fq-names ;; Find relevant children @@ -2874,7 +2874,7 @@ decode function to perform the actual decoding." (unless wtype ;; The node has type info encoded in it, but we don't know how to ;; decode it... - (error "Soap-decode-array: node has unknown type: %s" type))) + (error "soap-decode-array: Node has unknown type: %s" type))) (dolist (e contents) (when (consp e) (push (if wtype diff --git a/lisp/net/soap-inspect.el b/lisp/net/soap-inspect.el index 6f9ce6a2d69..eca338eb22d 100644 --- a/lisp/net/soap-inspect.el +++ b/lisp/net/soap-inspect.el @@ -6,7 +6,7 @@ ;; Created: October 2010 ;; Keywords: soap, web-services, comm, hypermedia ;; Package: soap-client -;; Homepage: https://github.com/alex-hhh/emacs-soap-client +;; URL: https://github.com/alex-hhh/emacs-soap-client ;; This file is part of GNU Emacs. @@ -114,7 +114,7 @@ This is a specialization of `soap-sample-value' for (cond ((soap-xs-simple-type-enumeration type) (let ((enumeration (soap-xs-simple-type-enumeration type))) - (nth (random (length enumeration)) enumeration))) + (and enumeration (seq-random-elt enumeration)))) ((soap-xs-simple-type-pattern type) (format "a string matching %s" (soap-xs-simple-type-pattern type))) ((soap-xs-simple-type-length-range type) @@ -124,7 +124,7 @@ This is a specialization of `soap-sample-value' for (format "a string between %d and %d chars long" low high)) (low (format "a string at least %d chars long" low)) (high (format "a string at most %d chars long" high)) - (t (format "a string OOPS"))))) + (t "a string OOPS")))) ((soap-xs-simple-type-integer-range type) (cl-destructuring-bind (min . max) (soap-xs-simple-type-integer-range type) (cond @@ -134,7 +134,7 @@ This is a specialization of `soap-sample-value' for (t (random 100))))) ((consp (soap-xs-simple-type-base type)) ; an union of values (let ((base (soap-xs-simple-type-base type))) - (soap-sample-value (nth (random (length base)) base)))) + (soap-sample-value (and base (seq-random-elt base))))) ((soap-xs-basic-type-p (soap-xs-simple-type-base type)) (soap-sample-value (soap-xs-simple-type-base type)))))) @@ -220,7 +220,7 @@ to its sub elements. If ELEMENT is the WSDL document itself, the entire WSDL can be inspected." (let ((inspect (get (soap-type-of element) 'soap-inspect))) (unless inspect - (error "Soap-inspect: no inspector for element")) + (error "soap-inspect: No inspector for element")) (with-current-buffer (get-buffer-create "*soap-inspect*") (setq buffer-read-only t) diff --git a/lisp/net/socks.el b/lisp/net/socks.el index 1da1d31d678..be299603a8c 100644 --- a/lisp/net/socks.el +++ b/lisp/net/socks.el @@ -154,7 +154,7 @@ (defcustom socks-server (list "Default server" "socks" 1080 5) - "" + "Socks server." :type '(list (string :format "" :value "Default server") (string :tag "Server") @@ -277,7 +277,7 @@ (setq version (process-get proc 'socks-server-protocol)) (cond ((equal version 'http) - (if (not (string-match "\r\n\r\n" string)) + (if (not (string-search "\r\n\r\n" string)) nil ; Need to spin some more (process-put proc 'socks-state socks-state-connected) (process-put proc 'socks-reply 0) @@ -453,7 +453,7 @@ When ATYPE indicates an IP, param ADDRESS must be given as raw bytes." ;; Replacement functions for open-network-stream, etc. (defvar socks-noproxy nil - "List of regexps matching hosts that we should not socksify connections to") + "List of regexps matching hosts that we should not socksify connections to.") (defun socks-find-route (host _service) (let ((route socks-server) diff --git a/lisp/net/telnet.el b/lisp/net/telnet.el index bb65ecaa981..1cf07a5ccec 100644 --- a/lisp/net/telnet.el +++ b/lisp/net/telnet.el @@ -73,8 +73,9 @@ LOGIN-NAME, which is optional, says what to log in as on that machine.") (defvar telnet-prompt-pattern "^[^#$%>\n]*[#$%>] *") (defvar telnet-replace-c-g nil) (defvar-local telnet-remote-echoes t - "True if the telnet process will echo input.") -(defvar-local telnet-interrupt-string "\C-c" "String sent by C-c.") + "Non-nil if the telnet process will echo input.") +(defvar-local telnet-interrupt-string "\C-c" + "String sent by C-c.") (defvar-local telnet-count 0 "Number of output strings from telnet process while looking for password.") @@ -83,8 +84,9 @@ LOGIN-NAME, which is optional, says what to log in as on that machine.") "Program to run to open a telnet connection.") (defvar telnet-initial-count -50 - "Initial value of `telnet-count'. Should be set to the negative of the -number of terminal writes telnet will make setting up the host connection.") + "Initial value of `telnet-count'. +Should be set to the negative of the number of terminal writes +telnet will make setting up the host connection.") (defvar telnet-maximum-count 4 "Maximum value `telnet-count' can have. @@ -105,7 +107,7 @@ rejecting one login and prompting again for a username and password.") (let (revert-buffer-function) (revert-buffer ignore-auto noconfirm)) (if (or noconfirm - (yes-or-no-p (format "Restart connection? "))) + (yes-or-no-p "Restart connection? ")) (apply telnet-connect-command)))) (defun telnet-c-z () @@ -122,7 +124,7 @@ rejecting one login and prompting again for a username and password.") ;;maybe should have a flag for when have found type (defun telnet-check-software-type-initialize (string) - "Tries to put correct initializations in. Needs work." + "Try to put correct initializations in. Needs work." (let ((case-fold-search t)) (cond ((string-match "unix" string) (setq telnet-prompt-pattern comint-prompt-regexp) @@ -245,7 +247,7 @@ Normally input is edited in Emacs and sent a line at a time." (define-derived-mode telnet-mode comint-mode "Telnet" "This mode is for using telnet (or rsh) from a buffer to another host. -It has most of the same commands as comint-mode. +It has most of the same commands as `comint-mode'. There is a variable `telnet-interrupt-string' which is the character sent to try to stop execution of a job on the remote host. Data is sent to the remote host when RET is typed." diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 5e0accc142a..362a258f43d 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -128,8 +128,7 @@ It is used for TCP/IP devices." (file-attributes . tramp-adb-handle-file-attributes) (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) + (file-executable-p . tramp-adb-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-adb-handle-file-local-copy) @@ -147,7 +146,7 @@ It is used for TCP/IP devices." (file-notify-rm-watch . tramp-handle-file-notify-rm-watch) (file-notify-valid-p . tramp-handle-file-notify-valid-p) (file-ownership-preserved-p . ignore) - (file-readable-p . tramp-handle-file-exists-p) + (file-readable-p . tramp-adb-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) @@ -361,7 +360,7 @@ arguments to pass to the OPERATION." (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 + ;; 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 (concat "ls --time-style=long-iso " @@ -442,7 +441,9 @@ Emacs dired can't find files." (make-directory par parents)))) (tramp-flush-directory-properties v localname) (unless (or (tramp-adb-send-command-and-check - v (format "mkdir %s" (tramp-shell-quote-argument localname))) + v (format "mkdir -m %#o %s" + (default-file-modes) + (tramp-shell-quote-argument localname))) (and parents (file-directory-p dir))) (tramp-error v 'file-error "Couldn't make directory %s" dir)))) @@ -513,28 +514,31 @@ Emacs dired can't find files." (set-file-modes tmpfile (logior (or (file-modes filename) 0) #o0400))) tmpfile))) +(defun tramp-adb-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-adb-send-command-and-check + v (format "test -x %s" (tramp-shell-quote-argument localname)))))) + +(defun tramp-adb-handle-file-readable-p (filename) + "Like `file-readable-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-readable-p" + (or (tramp-handle-file-readable-p filename) + (tramp-adb-send-command-and-check + v (format "test -r %s" (tramp-shell-quote-argument localname))))))) + (defun tramp-adb-handle-file-writable-p (filename) - "Like `file-writable-p' for Tramp files. -But handle the case, if the \"test\" command is not available." + "Like `file-writable-p' for Tramp files." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-writable-p" - (if (tramp-adb-find-test-command v) - (if (file-exists-p filename) - (tramp-adb-send-command-and-check - v (format "test -w %s" (tramp-shell-quote-argument localname))) - (and - (file-directory-p (file-name-directory filename)) - (file-writable-p (file-name-directory filename)))) - - ;; Missing "test" command on Android < 4. - (let ((rw-path "/data/data")) - (tramp-message - v 5 - "Not implemented yet (assuming \"/data/data\" is writable): %s" - localname) - (and (>= (length localname) (length rw-path)) - (string= (substring localname 0 (length rw-path)) - rw-path))))))) + (if (file-exists-p filename) + (tramp-adb-send-command-and-check + v (format "test -w %s" (tramp-shell-quote-argument localname))) + (and + (file-directory-p (file-name-directory filename)) + (file-writable-p (file-name-directory filename))))))) (defun tramp-adb-handle-write-region (start end filename &optional append visit lockname mustbenew) @@ -546,7 +550,7 @@ But handle the case, if the \"test\" command is not available." (or (eq mustbenew 'excl) (not (y-or-n-p - (format "File %s exists; overwrite anyway? " filename))))) + (format "File %s exists; overwrite anyway?" filename))))) (tramp-error v 'file-already-exists filename)) (let ((file-locked (eq (file-locked-p lockname) t)) @@ -598,7 +602,7 @@ But handle the case, if the \"test\" command is not available." ;; The end. (when (and (null noninteractive) - (or (eq visit t) (null visit) (stringp visit))) + (or (eq visit t) (string-or-null-p visit))) (tramp-message v 0 "Wrote %s" filename)) (run-hooks 'tramp-handle-write-region-hook)))) @@ -924,14 +928,15 @@ implementation will be used." (command (plist-get args :command)) (coding (plist-get args :coding)) (noquery (plist-get args :noquery)) - (connection-type (plist-get args :connection-type)) + (connection-type + (or (plist-get args :connection-type) process-connection-type)) (filter (plist-get args :filter)) (sentinel (plist-get args :sentinel)) (stderr (plist-get args :stderr))) (unless (stringp name) (signal 'wrong-type-argument (list #'stringp name))) - (unless (or (null buffer) (bufferp buffer) (stringp buffer)) - (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (or (bufferp buffer) (string-or-null-p buffer)) + (signal 'wrong-type-argument (list #'bufferp buffer))) (unless (consp command) (signal 'wrong-type-argument (list #'consp command))) (unless (or (null coding) @@ -940,13 +945,15 @@ implementation will be used." (memq (car coding) coding-system-list) (memq (cdr coding) coding-system-list))) (signal 'wrong-type-argument (list #'symbolp coding))) - (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (when (eq connection-type t) + (setq connection-type 'pty)) + (unless (memq connection-type '(nil pipe pty)) (signal 'wrong-type-argument (list #'symbolp connection-type))) - (unless (or (null filter) (functionp filter)) + (unless (or (null filter) (eq filter t) (functionp filter)) (signal 'wrong-type-argument (list #'functionp filter))) (unless (or (null sentinel) (functionp sentinel)) (signal 'wrong-type-argument (list #'functionp sentinel))) - (unless (or (null stderr) (bufferp stderr) (stringp stderr)) + (unless (or (bufferp stderr) (string-or-null-p stderr)) (signal 'wrong-type-argument (list #'bufferp stderr))) (when (and (stringp stderr) (tramp-tramp-file-p stderr) (not (tramp-equal-remote default-directory stderr))) @@ -1038,12 +1045,13 @@ implementation will be used." (rename-file remote-tmpstderr stderr)))) ;; Read initial output. Remove the first ;; line, which is the command echo. - (while - (progn - (goto-char (point-min)) - (not (re-search-forward "[\n]" nil t))) - (tramp-accept-process-output p 0)) - (delete-region (point-min) (point)) + (unless (eq filter t) + (while + (progn + (goto-char (point-min)) + (not (re-search-forward "[\n]" nil t))) + (tramp-accept-process-output p 0)) + (delete-region (point-min) (point))) ;; Provide error buffer. This shows only ;; initial error messages; messages arriving ;; later on will be inserted when the @@ -1065,7 +1073,7 @@ implementation will be used." p)))) ;; Save exit. - (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (if (string-prefix-p tramp-temp-buffer-name (buffer-name)) (ignore-errors (set-process-buffer (tramp-get-connection-process v) nil) (kill-buffer (current-buffer))) @@ -1136,12 +1144,6 @@ error and non-nil on success." (let ((inhibit-read-only t)) (delete-region (point-min) (point-max))) (zerop (apply #'tramp-call-process vec tramp-adb-program nil t nil args)))) -(defun tramp-adb-find-test-command (vec) - "Check whether the ash has a builtin \"test\" command. -This happens for Android >= 4.0." - (with-tramp-connection-property vec "test" - (tramp-adb-send-command-and-check vec "type test"))) - ;; Connection functions (defun tramp-adb-send-command (vec command &optional neveropen nooutput) @@ -1268,7 +1270,7 @@ connection if a previous connection has died for some reason." (list "-s" device "shell") (list "shell"))) (p (let ((default-directory - (tramp-compat-temporary-file-directory))) + tramp-compat-temporary-file-directory)) (apply #'start-process (tramp-get-connection-name vec) buf tramp-adb-program args))) (prompt (md5 (concat (prin1-to-string process-environment) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 67798e892ab..8bf25151dfb 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -190,7 +190,7 @@ It must be supported by libarchive(3).") ;; 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-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)) @@ -353,6 +353,7 @@ arguments to pass to the OPERATION." ;;;###autoload (progn (defun tramp-archive-autoload-file-name-handler (operation &rest args) "Load Tramp archive file name handler, and perform OPERATION." + (defvar tramp-archive-autoload) (when tramp-archive-enabled ;; We cannot use `tramp-compat-temporary-file-directory' here due ;; to autoload. When installing Tramp's GNU ELPA package, there @@ -360,7 +361,6 @@ arguments to pass to the OPERATION." ;; overload this. (let ((default-directory temporary-file-directory) (tramp-archive-autoload t)) - tramp-archive-autoload ; Silence byte compiler. (apply #'tramp-autoload-file-name-handler operation args))))) ;;;###autoload @@ -658,7 +658,7 @@ offered." ;; 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)))) + (tramp-compat-temporary-file-directory-function)))) (defun tramp-archive-handle-not-implemented (operation &rest args) "Generic handler for operations not implemented for file archives." diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 579234f9f50..5e7d24ff72b 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -72,8 +72,8 @@ ;; process key retrieved by `tramp-get-process' (the main connection ;; process). Other processes could reuse these properties, avoiding ;; recomputation when a new asynchronous process is created by -;; `make-process'. Examples are "remote-path", -;; "unsafe-temporary-file" or "device" (tramp-adb.el). +;; `make-process'. Examples are "unsafe-temporary-file", +;; "remote-path", "device" (tramp-adb.el) or "share" (tramp-gvfs.el). ;;; Code: @@ -101,8 +101,7 @@ details see the info pages." (choice :tag " Value" sexp)))) ;;;###tramp-autoload -(defcustom tramp-persistency-file-name - (expand-file-name (locate-user-emacs-file "tramp")) +(defcustom tramp-persistency-file-name (locate-user-emacs-file "tramp") "File which keeps connection history for Tramp connections." :group 'tramp :type 'file) @@ -125,7 +124,7 @@ If KEY is `tramp-cache-undefined', don't create anything, and return nil." (puthash key (make-hash-table :test #'equal) tramp-cache-data))) (when (tramp-file-name-p key) (dolist (elt tramp-connection-properties) - (when (string-match-p + (when (tramp-compat-string-search (or (nth 0 elt) "") (tramp-make-tramp-file-name key 'noloc 'nohop)) (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) @@ -268,8 +267,8 @@ Remove also properties of all files in subdirectories." (dolist (key (hash-table-keys tramp-cache-data)) (when (and (tramp-file-name-p key) (stringp (tramp-file-name-localname key)) - (string-match-p (regexp-quote directory) - (tramp-file-name-localname key))) + (tramp-compat-string-search + directory (tramp-file-name-localname key))) (remhash key tramp-cache-data))) ;; Remove file properties of symlinks. (when (and (stringp truename) @@ -319,12 +318,7 @@ KEY identifies the connection, it is either a process or a used to cache connection properties of the local machine. If KEY is `tramp-cache-undefined', or if the value is not set for the connection, return DEFAULT." - ;; 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)) + (setq key (tramp-file-name-unify key)) (let* ((hash (tramp-get-hash-table key)) (cached (if (hash-table-p hash) (gethash property hash tramp-cache-undefined) @@ -350,12 +344,7 @@ used to cache connection properties of the local machine. If KEY is `tramp-cache-undefined', nothing is set. PROPERTY is set persistent when KEY is a `tramp-file-name' structure. Return VALUE." - ;; 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)) + (setq key (tramp-file-name-unify key)) (when-let ((hash (tramp-get-hash-table key))) (puthash property value hash)) (setq tramp-cache-data-changed @@ -379,12 +368,7 @@ 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)) + (setq key (tramp-file-name-unify key)) (when-let ((hash (tramp-get-hash-table key))) (remhash property hash)) (setq tramp-cache-data-changed @@ -397,12 +381,7 @@ PROPERTY is set persistent when KEY is a `tramp-file-name' structure." 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." - ;; 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)) + (setq key (tramp-file-name-unify key)) (tramp-message key 7 "%s %s" key (when-let ((hash (gethash key tramp-cache-data))) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index d30d22021a5..63eab1b31a1 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -131,6 +131,8 @@ When called interactively, a Tramp connection has to be selected." (buf (list (get-buffer (tramp-buffer-name vec)) (unless keep-debug (get-buffer (tramp-debug-buffer-name vec))) + (unless keep-debug + (get-buffer (tramp-trace-buffer-name vec))) (tramp-get-connection-property vec "process-buffer" nil))) (when (bufferp buf) (kill-buffer buf))) @@ -312,7 +314,7 @@ The remote connection identified by SOURCE is flushed by (if (null connections) (tramp-user-error nil "There are no remote connections.") (setq source - ;; Likely, the source remote connection is broken. So we + ;; Likely, the source remote connection is broken. So we ;; shall avoid any action on it. (let (non-essential) (completing-read-default @@ -672,7 +674,7 @@ buffer in your bug report. (insert "\nload-path shadows:\n==================\n") (ignore-errors (mapc - (lambda (x) (when (string-match-p "tramp" x) (insert x "\n"))) + (lambda (x) (when (tramp-compat-string-search "tramp" x) (insert x "\n"))) (split-string (list-load-path-shadows t) "\n"))) ;; Append buffers only when we are in message mode. @@ -717,7 +719,7 @@ the debug buffer(s).") (setq buffer-read-only t) (goto-char (point-min)) - (when (y-or-n-p "Do you want to append the buffer(s)? ") + (when (y-or-n-p "Do you want to append the buffer(s)?") ;; OK, let's send. First we delete the buffer list. (kill-buffer nil) (switch-to-buffer curbuf) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 6e464073379..213ab5857c5 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -63,25 +63,24 @@ `(when (functionp ,function) (with-no-warnings (funcall ,function ,@arguments)))) -(defsubst tramp-compat-temporary-file-directory () - "Return name of directory for temporary files. -It is the default value of `temporary-file-directory'." - ;; We must return a local directory. If it is remote, we could run - ;; into an infloop. - (eval (car (get 'temporary-file-directory 'standard-value)) t)) +;; We must use a local directory. If it is remote, we could run into +;; an infloop. +(defconst tramp-compat-temporary-file-directory + (eval (car (get 'temporary-file-directory 'standard-value)) t) + "The default value of `temporary-file-directory'.") (defsubst tramp-compat-make-temp-name () "Generate a local temporary file name (compat function)." (make-temp-name (expand-file-name - tramp-temp-name-prefix (tramp-compat-temporary-file-directory)))) + tramp-temp-name-prefix tramp-compat-temporary-file-directory))) (defsubst tramp-compat-make-temp-file (f &optional dir-flag) "Create a local temporary file (compat function). Add the extension of F, if existing." (make-temp-file (expand-file-name - tramp-temp-name-prefix (tramp-compat-temporary-file-directory)) + tramp-temp-name-prefix tramp-compat-temporary-file-directory) dir-flag (file-name-extension f t))) ;; `temporary-file-directory' as function is introduced with Emacs 26.1. @@ -295,6 +294,15 @@ A nil value for either argument stands for the current time." (lambda (reporter &optional value _suffix) (progress-reporter-update reporter value)))) +;; `ignore-error' is new in Emacs Emacs 27.1. +(defmacro tramp-compat-ignore-error (condition &rest body) + "Execute BODY; if the error CONDITION occurs, return nil. +Otherwise, return result of last form in BODY. + +CONDITION can also be a list of error conditions." + (declare (debug t) (indent 1)) + `(condition-case nil (progn ,@body) (,condition nil))) + ;; `file-modes', `set-file-modes' and `set-file-times' got argument ;; FLAG in Emacs 28.1. (defalias 'tramp-compat-file-modes @@ -350,8 +358,18 @@ A nil value for either argument stands for the current time." (defalias 'tramp-compat-string-replace (if (fboundp 'string-replace) #'string-replace - (lambda (fromstring tostring instring) - (replace-regexp-in-string (regexp-quote fromstring) tostring instring)))) + (lambda (from-string to-string in-string) + (let ((case-fold-search nil)) + (replace-regexp-in-string + (regexp-quote from-string) to-string in-string t t))))) + +;; Function `string-search' is new in Emacs 28.1. +(defalias 'tramp-compat-string-search + (if (fboundp 'string-search) + #'string-search + (lambda (needle haystack &optional start-pos) + (let ((case-fold-search nil)) + (string-match-p (regexp-quote needle) haystack start-pos))))) ;; Function `make-lock-file-name' is new in Emacs 28.1. (defalias 'tramp-compat-make-lock-file-name diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index fdb2907ec32..269560bfa94 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -247,7 +247,7 @@ Operations not mentioned here will be handled by the default Emacs primitives.") (unless (tramp-crypt-file-name-p tfnfo) (setq tfnfo (apply #'tramp-file-name-for-operation operation - (cons (tramp-compat-temporary-file-directory) (cdr args))))) + (cons tramp-compat-temporary-file-directory (cdr args))))) tfnfo)) (defun tramp-crypt-run-real-handler (operation args) @@ -293,9 +293,8 @@ arguments to pass to the OPERATION." (defun tramp-crypt-config-file-name (vec) "Return the encfs config file name for VEC." - (expand-file-name - (concat "tramp-" (tramp-file-name-host vec) tramp-crypt-encfs-config) - user-emacs-directory)) + (locate-user-emacs-file + (concat "tramp-" (tramp-file-name-host vec) tramp-crypt-encfs-config))) (defun tramp-crypt-maybe-open-connection (vec) "Maybe open a connection VEC. @@ -329,7 +328,7 @@ connection if a previous connection has died for some reason." (copy-file remote-config local-config 'ok 'keep) ;; Create local encfs6 config file otherwise. - (let* ((default-directory (tramp-compat-temporary-file-directory)) + (let* ((default-directory tramp-compat-temporary-file-directory) (tmpdir1 (file-name-as-directory (tramp-compat-make-temp-file " .crypt" 'dir-flag))) (tmpdir2 (file-name-as-directory @@ -383,7 +382,7 @@ ARGS are the arguments. It returns t if ran successful, and nil otherwise." (with-temp-buffer (let* (;; Don't check for a proper method. (non-essential t) - (default-directory (tramp-compat-temporary-file-directory)) + (default-directory tramp-compat-temporary-file-directory) ;; We cannot add it to `process-environment', because ;; `tramp-call-process-region' doesn't use it. (encfs-config @@ -427,7 +426,7 @@ Otherwise, return NAME." crypt-vec localname (concat (symbol-name op) "-file-name") (unless (tramp-crypt-send-command crypt-vec (if (eq op 'encrypt) "encode" "decode") - (tramp-compat-temporary-file-directory) localname) + tramp-compat-temporary-file-directory localname) (tramp-error crypt-vec 'file-error "%s of file name %s failed." (if (eq op 'encrypt) "Encoding" "Decoding") name)) @@ -517,7 +516,7 @@ kept in their encrypted form." tramp-crypt-encfs-config (directory-files name nil directory-files-no-dot-files-regexp)) (yes-or-no-p - "There exist encrypted files, do you want to continue? ")) + "There exist encrypted files, do you want to continue?")) (setq tramp-crypt-directories (delete name tramp-crypt-directories)) (tramp-register-file-name-handlers))) diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index fa2df89e495..11ccdc8a4c9 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -120,15 +120,15 @@ pass to the OPERATION." (nth 2 tramp-file-name-structure) (nth 4 tramp-file-name-structure))) ;; ange-ftp uses `ange-ftp-ftp-name-arg' and `ange-ftp-ftp-name-res' - ;; for optimization in `ange-ftp-ftp-name'. If Tramp wasn't active, + ;; for optimization in `ange-ftp-ftp-name'. If Tramp wasn't active, ;; there could be incorrect values from previous calls in case the - ;; "ftp" method is used in the Tramp file name. So we unset + ;; "ftp" method is used in the Tramp file name. So we unset ;; those values. (ange-ftp-ftp-name-arg "") (ange-ftp-ftp-name-res nil)) (cond ;; If argument is a symlink, `file-directory-p' and - ;; `file-exists-p' call the traversed file recursively. So we + ;; `file-exists-p' call the traversed file recursively. So we ;; cannot disable the file-name-handler this case. We set the ;; connection property "started" in order to put the remote ;; location into the cache, which is helpful for further diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el index 93b184a36c2..c359082dc1e 100644 --- a/lisp/net/tramp-fuse.el +++ b/lisp/net/tramp-fuse.el @@ -154,36 +154,58 @@ (when (tramp-file-name-user vec) (concat (tramp-file-name-user-domain vec) "@")) (tramp-file-name-host-port vec)) - (tramp-compat-temporary-file-directory)))) + tramp-compat-temporary-file-directory))) + +(defconst tramp-fuse-mount-timeout + (eval (car (get 'remote-file-name-inhibit-cache 'standard-value)) t) + "Time period to check whether the mount point still exists. +It has the same meaning as `remote-file-name-inhibit-cache'.") (defun tramp-fuse-mounted-p (vec) "Check, whether fuse volume 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) - (let* ((default-directory (tramp-compat-temporary-file-directory)) + ;; Remember the mount status by using a file property on "/", + ;; instead of using a connection property, because a file property + ;; has a timeout. Having a timeout lets us regularly recheck the + ;; mount status, as requested by `tramp-fuse-mount-timeout'. We + ;; cannot use `with-tramp-file-property', because we don't want to + ;; cache a nil result. + (let ((remote-file-name-inhibit-cache tramp-fuse-mount-timeout)) + (or (tramp-get-file-property vec "/" "mounted" nil) + (let* ((default-directory tramp-compat-temporary-file-directory) (command (format "mount -t fuse.%s" (tramp-file-name-method vec))) (mount (shell-command-to-string command))) (tramp-message vec 6 "%s\n%s" command mount) - (tramp-set-connection-property - (tramp-get-connection-process vec) "mounted" + (tramp-set-file-property + vec "/" "mounted" (when (string-match (format "^\\(%s\\)\\s-" (regexp-quote (tramp-fuse-mount-spec vec))) mount) (match-string 1 mount))))))) +(defun tramp-fuse-get-fusermount () + "Determine the local `fusermount' command." + ;; We use key nil for local connection properties. + (with-tramp-connection-property nil "fusermount" + (or (executable-find "fusermount3") + (executable-find "fusermount")))) + +(defvar tramp-fuse-mount-points nil + "List of fuse volume determined by a VEC.") + (defun tramp-fuse-unmount (vec) "Unmount fuse volume determined by VEC." - (let ((default-directory (tramp-compat-temporary-file-directory)) - (command (format "fusermount3 -u %s" (tramp-fuse-mount-point vec)))) + (let* ((default-directory tramp-compat-temporary-file-directory) + (mount-point (tramp-fuse-mount-point vec)) + (command (format "%s -u %s" (tramp-fuse-get-fusermount) mount-point))) (tramp-message vec 6 "%s\n%s" command (shell-command-to-string command)) - (tramp-flush-connection-property - (tramp-get-connection-process vec) "mounted") + (tramp-flush-file-property vec "/" "mounted") + (setq tramp-fuse-mount-points + (delete (tramp-file-name-unify vec) tramp-fuse-mount-points)) ;; Give the caches a chance to expire. - (sleep-for 1))) + (sleep-for 1) + (when (tramp-compat-directory-empty-p mount-point) + (delete-directory mount-point)))) (defun tramp-fuse-local-file-name (filename) "Return local mount name of FILENAME." @@ -205,6 +227,36 @@ (substring localname 1) localname) (tramp-fuse-mount-point v))))))) +(defcustom tramp-fuse-unmount-on-cleanup nil + "Whether fuse volumes shall be unmounted on cleanup." + :group 'tramp + :version "28.1" + :type 'boolean) + +(defun tramp-fuse-cleanup (vec) + "Cleanup fuse volume determined by VEC." + (and tramp-fuse-unmount-on-cleanup + (member (tramp-file-name-unify vec) tramp-fuse-mount-points) + (tramp-fuse-unmount vec))) + +(defun tramp-fuse-cleanup-all () + "Unmount all fuse volumes used by Tramp." + (and tramp-fuse-unmount-on-cleanup + (mapc #'tramp-fuse-unmount tramp-fuse-mount-points))) + +;; Add cleanup hooks. +(add-hook 'tramp-cleanup-connection-hook #'tramp-fuse-cleanup) +(add-hook 'tramp-cleanup-all-connections-hook #'tramp-fuse-cleanup-all) +(add-hook 'kill-emacs-hook #'tramp-fuse-cleanup-all) +(add-hook 'tramp-fuse-unload-hook + (lambda () + (remove-hook 'tramp-cleanup-connection-hook + #'tramp-fuse-cleanup) + (remove-hook 'tramp-cleanup-all-connections-hook + #'tramp-fuse-cleanup-all) + (remove-hook 'kill-emacs-hook + #'tramp-fuse-cleanup-all))) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-fuse 'force))) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index db561b4fd0c..cab912bd93a 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -788,7 +788,7 @@ It has been changed in GVFS 1.14.") (file-notify-rm-watch . tramp-handle-file-notify-rm-watch) (file-notify-valid-p . tramp-handle-file-notify-valid-p) (file-ownership-preserved-p . ignore) - (file-readable-p . tramp-gvfs-handle-file-readable-p) + (file-readable-p . tramp-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) @@ -1396,12 +1396,11 @@ If FILE-SYSTEM is non-nil, return file system attributes." "Like `file-executable-p' for Tramp files." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-executable-p" - (and (file-exists-p filename) - (tramp-check-cached-permissions v ?x))))) + (tramp-check-cached-permissions v ?x)))) (defun tramp-gvfs-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (unless (string-match-p "/" filename) + (unless (tramp-compat-string-search "/" filename) (all-completions filename (with-parsed-tramp-file-name (expand-file-name directory) nil @@ -1519,31 +1518,6 @@ If FILE-SYSTEM is non-nil, return file system attributes." (when string (tramp-message proc 10 "Rest string:\n%s" string)) (process-put proc 'rest-string string))) -(defun tramp-gvfs-handle-file-readable-p (filename) - "Like `file-readable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-tramp-file-property v localname "file-readable-p" - (and (file-exists-p filename) - (or (tramp-check-cached-permissions v ?r) - ;; `tramp-check-cached-permissions' doesn't handle - ;; symbolic links. - (and (stringp (file-symlink-p filename)) - (file-readable-p - (concat - (file-remote-p filename) (file-symlink-p filename)))) - ;; If the user is different from what we guess to be - ;; the user, we don't know. Let's check, whether - ;; access is restricted explicitly. - (and (/= (tramp-get-remote-uid v 'integer) - (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer))) - (not - (string-equal - "FALSE" - (cdr (assoc - "access::can-read" - (tramp-gvfs-get-file-attributes filename))))))))))) - (defun tramp-gvfs-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." (setq filename (directory-file-name (expand-file-name filename))) @@ -1574,10 +1548,13 @@ If FILE-SYSTEM is non-nil, return file system attributes." (when (and parents (not (file-directory-p ldir))) (make-directory ldir parents)) ;; Just do it. - (unless (or (tramp-gvfs-send-command - v "gvfs-mkdir" (tramp-gvfs-url-file-name dir)) - (and parents (file-directory-p dir))) - (tramp-error v 'file-error "Couldn't make directory %s" dir)))))) + (or (when-let ((mkdir-succeeded + (tramp-gvfs-send-command + v "gvfs-mkdir" (tramp-gvfs-url-file-name dir)))) + (set-file-modes dir (default-file-modes)) + mkdir-succeeded) + (and parents (file-directory-p dir)) + (tramp-error v 'file-error "Couldn't make directory %s" dir)))))) (defun tramp-gvfs-handle-rename-file (filename newname &optional ok-if-already-exists) @@ -1633,8 +1610,10 @@ If FILE-SYSTEM is non-nil, return file system attributes." ID-FORMAT valid values are `string' and `integer'." (if (equal id-format 'string) (tramp-file-name-user vec) - (when-let - ((localname (tramp-get-connection-property vec "default-location" nil))) + (when-let ((localname + (tramp-get-connection-property + (tramp-get-process vec) "share" + (tramp-get-connection-property vec "default-location" nil)))) (tramp-compat-file-attribute-user-id (file-attributes (tramp-make-tramp-file-name vec localname) id-format))))) @@ -1642,8 +1621,10 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-gvfs-handle-get-remote-gid (vec id-format) "The gid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." - (when-let - ((localname (tramp-get-connection-property vec "default-location" nil))) + (when-let ((localname + (tramp-get-connection-property + (tramp-get-process vec) "share" + (tramp-get-connection-property vec "default-location" nil)))) (tramp-compat-file-attribute-group-id (file-attributes (tramp-make-tramp-file-name vec localname) id-format)))) @@ -1808,10 +1789,8 @@ a downcased host name only." (message "%s" message) (pop-to-buffer (current-buffer))) (if (yes-or-no-p - (concat - (buffer-substring - (line-beginning-position) (point)) - " ")) + (buffer-substring + (line-beginning-position) (point))) 0 1))))) ;; When QUIT is raised, we shall return this @@ -1828,12 +1807,13 @@ a downcased host name only." result)))) (defun tramp-gvfs-handler-mounted-unmounted (mount-info) - "Signal handler for the \"org.gtk.vfs.MountTracker.mounted\" and \ -\"org.gtk.vfs.MountTracker.unmounted\" signals." + "Signal handler for the gvfs \"mounted\" and \"unmounted\" signals. +Their full names are \"org.gtk.vfs.MountTracker.mounted\" and +\"org.gtk.vfs.MountTracker.unmounted\"." (ignore-errors (let ((signal-name (dbus-event-member-name last-input-event)) (elt mount-info)) - ;; Jump over the first elements of the mount info. Since there + ;; Jump over the first elements of the mount info. Since there ;; were changes in the entries, we cannot access dedicated ;; elements. (while (stringp (car elt)) (setq elt (cdr elt))) @@ -1885,8 +1865,9 @@ a downcased host name only." host (tramp-file-name-host v) port (tramp-file-name-port v))))) (when (member method tramp-gvfs-methods) - (with-parsed-tramp-file-name - (tramp-make-tramp-file-name method user domain host port "") nil + (let ((v (make-tramp-file-name + :method method :user user :domain domain + :host host :port port))) (tramp-message v 6 "%s %s" signal-name (tramp-gvfs-stringify-dbus-message mount-info)) @@ -1929,7 +1910,7 @@ a downcased host name only." :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker tramp-gvfs-interface-mounttracker tramp-gvfs-listmounts)) nil) - ;; Jump over the first elements of the mount info. Since there + ;; Jump over the first elements of the mount info. Since there ;; were changes in the entries, we cannot access dedicated ;; elements. (while (stringp (car elt)) (setq elt (cdr elt))) @@ -1997,6 +1978,9 @@ a downcased host name only." (tramp-set-file-property vec "/" "fuse-mountpoint" fuse-mountpoint) (tramp-set-connection-property vec "default-location" default-location) + (when share + (tramp-set-connection-property + (tramp-get-process vec) "share" (concat "/" share))) (throw 'mounted t))))))) (defun tramp-gvfs-unmount (vec) @@ -2082,8 +2066,10 @@ It was \"a(say)\", but has changed to \"a{sv})\"." `(:struct ,(tramp-gvfs-dbus-string-to-byte-array mount-pref) ,mount-spec))) (defun tramp-gvfs-handler-volumeadded-volumeremoved (_dbus-name _id volume) - "Signal handler for the \"org.gtk.Private.RemoteVolumeMonitor.VolumeAdded\" \ -and \"org.gtk.Private.RemoteVolumeMonitor.VolumeRemoved\" signals." + "Signal handler for the gvfs \"VolumeAdded\" and \"VolumeRemoved\" signals. +Their full names are +\"org.gtk.Private.RemoteVolumeMonitor.VolumeAdded\" and +\"org.gtk.Private.RemoteVolumeMonitor.VolumeRemoved\"." (ignore-errors (let* ((signal-name (dbus-event-member-name last-input-event)) (uri (url-generic-parse-url (nth 5 volume))) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 49e366c01c6..812e06f3f11 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -386,6 +386,7 @@ connection if a previous connection has died for some reason." (tramp-cleanup-connection vec 'keep-debug 'keep-password)) ;; Mark it as connected. + (add-to-list 'tramp-fuse-mount-points (tramp-file-name-unify vec)) (tramp-set-connection-property (tramp-get-connection-process vec) "connected" t)))) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 7cf90b96612..b20e5f80732 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -202,7 +202,7 @@ The string is used in `tramp-methods'.") (tramp-copy-program "rsync") (tramp-copy-args (("-t" "%k") ("-p") ("-r") ("-s") ("-c"))) - (tramp-copy-env (("RSYNC_RSH") ("ssh" "%c"))) + (tramp-copy-env (("RSYNC_RSH") ("ssh") ("%c"))) (tramp-copy-keep-date t) (tramp-copy-keep-tmpfile t) (tramp-copy-recursive t))) @@ -280,13 +280,14 @@ The string is used in `tramp-methods'.") (tramp-connection-timeout 10))) (add-to-list 'tramp-methods `("sudo" - (tramp-login-program "sudo") + (tramp-login-program "env") ;; The password template must be masked. Otherwise, ;; it could be interpreted as password prompt if the ;; remote host echoes the command. - (tramp-login-args (("-u" "%u") ("-s") ("-H") - ("-p" "P\"\"a\"\"s\"\"s\"\"w\"\"o\"\"r\"\"d\"\":") - ("%l"))) + ;; The "-p" argument doesn't work reliably, see Bug#50594. + (tramp-login-args (("SUDO_PROMPT=P\"\"a\"\"s\"\"s\"\"w\"\"o\"\"r\"\"d\"\":") + ("sudo") ("-u" "%u") ("-s") ("-H") + ("%l"))) (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) @@ -519,7 +520,7 @@ shell from reading its init file." (tramp-yn-prompt-regexp tramp-action-yn) (tramp-terminal-prompt-regexp tramp-action-terminal) (tramp-antispoof-regexp tramp-action-confirm-message) - (tramp-yubikey-regexp tramp-action-show-and-confirm-message) + (tramp-security-key-confirm-regexp tramp-action-show-and-confirm-message) (tramp-process-alive-regexp tramp-action-process-alive)) "List of pattern/action pairs. Whenever a pattern matches, the corresponding action is performed. @@ -537,7 +538,7 @@ corresponding PATTERN matches, the ACTION function is called.") '((tramp-password-prompt-regexp tramp-action-password) (tramp-wrong-passwd-regexp tramp-action-permission-denied) (tramp-copy-failed-regexp tramp-action-permission-denied) - (tramp-yubikey-regexp tramp-action-show-and-confirm-message) + (tramp-security-key-confirm-regexp tramp-action-show-and-confirm-message) (tramp-process-alive-regexp tramp-action-out-of-band)) "List of pattern/action pairs. This list is used for copying/renaming with out-of-band methods. @@ -1063,7 +1064,7 @@ component is used as the target of the symlink." (not (yes-or-no-p (format - "File %s already exists; make it a link anyway? " + "File %s already exists; make it a link anyway?" localname))))) (tramp-error v 'file-already-exists localname) (delete-file linkname))) @@ -1072,7 +1073,7 @@ component is used as the target of the symlink." ;; Right, they are on the same host, regardless of user, ;; method, etc. We now make the link on the remote - ;; machine. This will occur as the user that TARGET belongs to. + ;; machine. This will occur as the user that TARGET belongs to. (and (tramp-send-command-and-check v (format "cd %s" (tramp-shell-quote-argument cwd))) (tramp-send-command-and-check @@ -1579,9 +1580,7 @@ ID-FORMAT valid values are `string' and `integer'." "Like `file-readable-p' for Tramp files." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-readable-p" - ;; Examine `file-attributes' cache to see if request can be - ;; satisfied without remote operation. - (or (tramp-check-cached-permissions v ?r) + (or (tramp-handle-file-readable-p filename) (tramp-run-test "-r" filename))))) ;; Functions implemented using the basic functions above. @@ -1627,9 +1626,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; On BSD-derived systems files always inherit the ;; parent directory's group, so skip the group-gid ;; test. - (string-match-p - "BSD\\|DragonFly\\|Darwin" - (tramp-get-connection-property v "uname" "")) + (tramp-check-remote-uname v "BSD\\|DragonFly\\|Darwin") (= (tramp-compat-file-attribute-group-id attributes) (tramp-get-remote-gid v 'integer))))))))) @@ -1700,7 +1697,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; FIXME: Fix function to work with count parameter. (defun tramp-do-directory-files-and-attributes-with-stat (vec localname &optional id-format) - "Implement `directory-files-and-attributes' for Tramp files using stat(1) command." + "Implement `directory-files-and-attributes' for Tramp files with stat(1) command." (tramp-message vec 5 "directory-files-and-attributes with stat: %s" localname) (tramp-send-command-and-read vec @@ -1740,7 +1737,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; files. (defun tramp-sh-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (unless (string-match-p "/" filename) + (unless (tramp-compat-string-search "/" filename) (all-completions filename (with-parsed-tramp-file-name (expand-file-name directory) nil @@ -1824,7 +1821,7 @@ ID-FORMAT valid values are `string' and `integer'." (and (numberp ok-if-already-exists) (not (yes-or-no-p (format - "File %s already exists; make it a link anyway? " + "File %s already exists; make it a link anyway?" v2-localname))))) (tramp-error v2 'file-already-exists newname) (delete-file newname))) @@ -1857,41 +1854,53 @@ ID-FORMAT valid values are `string' and `integer'." (dirname newname &optional keep-date parents copy-contents) "Like `copy-directory' for Tramp files." (let ((t1 (tramp-tramp-file-p dirname)) - (t2 (tramp-tramp-file-p newname))) + (t2 (tramp-tramp-file-p newname)) + target) (with-parsed-tramp-file-name (if t1 dirname newname) nil (unless (file-exists-p dirname) (tramp-compat-file-missing v dirname)) - (if (and (not copy-contents) - (tramp-get-method-parameter v 'tramp-copy-recursive) - ;; When DIRNAME and NEWNAME are remote, they must have - ;; the same method. - (or (null t1) (null t2) - (string-equal - (tramp-file-name-method (tramp-dissect-file-name dirname)) - (tramp-file-name-method - (tramp-dissect-file-name newname))))) - ;; scp or rsync DTRT. - (progn - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-already-exists newname)) - (setq dirname (directory-file-name (expand-file-name dirname)) - newname (directory-file-name (expand-file-name newname))) - (when (and (file-directory-p newname) - (not (string-equal (file-name-nondirectory dirname) - (file-name-nondirectory newname)))) - (setq newname - (expand-file-name - (file-name-nondirectory dirname) newname))) - (unless (file-directory-p (file-name-directory newname)) + + ;; `copy-directory-create-symlink' exists since Emacs 28.1. + (if (and (bound-and-true-p copy-directory-create-symlink) + (setq target (file-symlink-p dirname)) + (tramp-equal-remote dirname newname)) + (make-symbolic-link + target + (if (directory-name-p newname) + (concat newname (file-name-nondirectory dirname)) newname) + t) + + (if (and (not copy-contents) + (tramp-get-method-parameter v 'tramp-copy-recursive) + ;; When DIRNAME and NEWNAME are remote, they must + ;; have the same method. + (or (null t1) (null t2) + (string-equal + (tramp-file-name-method (tramp-dissect-file-name dirname)) + (tramp-file-name-method + (tramp-dissect-file-name newname))))) + ;; scp or rsync DTRT. + (progn + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-already-exists newname)) + (setq dirname (directory-file-name (expand-file-name dirname)) + newname (directory-file-name (expand-file-name newname))) + (when (and (file-directory-p newname) + (not (string-equal (file-name-nondirectory dirname) + (file-name-nondirectory newname)))) + (setq newname + (expand-file-name + (file-name-nondirectory dirname) newname))) + (unless (file-directory-p (file-name-directory newname)) (make-directory (file-name-directory newname) parents)) - (tramp-do-copy-or-rename-file-out-of-band - 'copy dirname newname 'ok-if-already-exists keep-date)) + (tramp-do-copy-or-rename-file-out-of-band + 'copy dirname newname 'ok-if-already-exists keep-date)) - ;; We must do it file-wise. - (tramp-run-real-handler - #'copy-directory - (list dirname newname keep-date parents copy-contents))) + ;; We must do it file-wise. + (tramp-run-real-handler + #'copy-directory + (list dirname newname keep-date parents copy-contents)))) ;; When newname did exist, we have wrong cached values. (when t2 @@ -2218,7 +2227,7 @@ the uid and gid from FILENAME." ;; Save exit. (ignore-errors (delete-file tmpfile))))))))) - ;; Set the time and mode. Mask possible errors. + ;; Set the time and mode. Mask possible errors. (ignore-errors (when keep-date (tramp-compat-set-file-times @@ -2309,7 +2318,8 @@ The method used must be an out-of-band method." copy-args (tramp-compat-flatten-tree (mapcar - (lambda (x) (if (string-match-p " " x) (split-string x) x)) + (lambda (x) (if (tramp-compat-string-search " " x) + (split-string x) x)) copy-args)) copy-env (apply #'tramp-expand-args v 'tramp-copy-env spec) remote-copy-program @@ -2377,7 +2387,7 @@ The method used must be an out-of-band method." ;; can be handled. We don't set a timeout, because ;; the copying of large files can last longer than 60 ;; secs. - p (let ((default-directory (tramp-compat-temporary-file-directory))) + p (let ((default-directory tramp-compat-temporary-file-directory)) (apply #'start-process (tramp-get-connection-name v) @@ -2436,8 +2446,9 @@ The method used must be an out-of-band method." (tramp-flush-directory-properties v (if parents "/" (file-name-directory localname))) (tramp-barf-unless-okay - v (format "%s %s" + v (format "%s -m %#o %s" (if parents "mkdir -p" "mkdir") + (default-file-modes) (tramp-shell-quote-argument localname)) "Couldn't make directory %s" dir))) @@ -2483,9 +2494,14 @@ The method used must be an out-of-band method." (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) + v (if (string-match-p "%[io]" (nth 2 suffix)) + (replace-regexp-in-string + "%i" (tramp-shell-quote-argument localname) + (nth 2 suffix)) + (concat (nth 2 suffix) " " + (tramp-shell-quote-argument localname)))) + (unless (string-match-p "\\.tar\\.gz" file) + (dired-remove-file file)) (string-match (car suffix) file) (concat (substring file 0 (match-beginning 0)))))) (t @@ -2493,14 +2509,21 @@ The method used must be an out-of-band method." ;; 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))))))))) + v (if (file-directory-p file) + (format "tar -cf - %s | gzip -c9 > %s.tar.gz" + (tramp-shell-quote-argument + (file-name-nondirectory localname)) + (tramp-shell-quote-argument localname)) + (concat "gzip -f " + (tramp-shell-quote-argument localname)))) + (unless (file-directory-p file) + (dired-remove-file file)) + (catch 'found nil + (dolist (target (mapcar (lambda (suffix) + (concat file suffix)) + '(".tar.gz" ".gz" ".z"))) + (when (file-exists-p target) + (throw 'found target))))))))))) (defun tramp-sh-handle-insert-directory (filename switches &optional wildcard full-directory-p) @@ -2602,8 +2625,8 @@ The method used must be an out-of-band method." (save-restriction (narrow-to-region beg-marker end-marker) ;; Some busyboxes are reluctant to discard colors. - (unless - (string-match-p "color" (tramp-get-connection-property v "ls" "")) + (unless (tramp-compat-string-search + "color" (tramp-get-connection-property v "ls" "")) (goto-char (point-min)) (while (re-search-forward tramp-display-escape-sequence-regexp nil t) (replace-match ""))) @@ -2682,11 +2705,11 @@ the result will be a local, non-Tramp, file name." ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) (setq name (tramp-compat-file-name-concat dir name))) - ;; If connection is not established yet, run the real handler. - (if (not (tramp-connectable-p name)) - (tramp-run-real-handler #'expand-file-name (list name nil)) - ;; Dissect NAME. - (with-parsed-tramp-file-name name nil + ;; Dissect NAME. + (with-parsed-tramp-file-name name nil + ;; If connection is not established yet, run the real handler. + (if (not (tramp-connectable-p v)) + (tramp-run-real-handler #'expand-file-name (list name nil)) (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "~/" localname))) ;; Tilde expansion if necessary. This needs a shell which @@ -2725,7 +2748,7 @@ the result will be a local, non-Tramp, file name." ;; `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))) + (let ((default-directory tramp-compat-temporary-file-directory)) (tramp-make-tramp-file-name v (tramp-drop-volume-letter (tramp-run-real-handler @@ -2733,7 +2756,7 @@ the result will be a local, non-Tramp, file name." ;;; Remote commands: -;; We use BUFFER also as connection buffer during setup. Because of +;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once ;; connection has been setup. (defun tramp-sh-handle-make-process (&rest args) @@ -2751,14 +2774,15 @@ implementation will be used." (command (plist-get args :command)) (coding (plist-get args :coding)) (noquery (plist-get args :noquery)) - (connection-type (plist-get args :connection-type)) + (connection-type + (or (plist-get args :connection-type) process-connection-type)) (filter (plist-get args :filter)) (sentinel (plist-get args :sentinel)) (stderr (plist-get args :stderr))) (unless (stringp name) (signal 'wrong-type-argument (list #'stringp name))) - (unless (or (null buffer) (bufferp buffer) (stringp buffer)) - (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (or (bufferp buffer) (string-or-null-p buffer)) + (signal 'wrong-type-argument (list #'bufferp buffer))) (unless (or (null command) (consp command)) (signal 'wrong-type-argument (list #'consp command))) (unless (or (null coding) @@ -2767,13 +2791,15 @@ implementation will be used." (memq (car coding) coding-system-list) (memq (cdr coding) coding-system-list))) (signal 'wrong-type-argument (list #'symbolp coding))) - (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (when (eq connection-type t) + (setq connection-type 'pty)) + (unless (memq connection-type '(nil pipe pty)) (signal 'wrong-type-argument (list #'symbolp connection-type))) - (unless (or (null filter) (functionp filter)) + (unless (or (null filter) (eq filter t) (functionp filter)) (signal 'wrong-type-argument (list #'functionp filter))) (unless (or (null sentinel) (functionp sentinel)) (signal 'wrong-type-argument (list #'functionp sentinel))) - (unless (or (null stderr) (bufferp stderr) (stringp stderr)) + (unless (or (bufferp stderr) (string-or-null-p stderr)) (signal 'wrong-type-argument (list #'bufferp stderr))) (when (and (stringp stderr) (not (tramp-equal-remote default-directory stderr))) @@ -2828,7 +2854,7 @@ implementation will be used." (env (dolist (elt (cons prompt process-environment) env) (or (member elt (default-toplevel-value 'process-environment)) - (if (string-match-p "=" elt) + (if (tramp-compat-string-search "=" elt) (setq env (append env `(,elt))) (setq uenv (cons elt uenv)))))) (env (setenv-internal @@ -2865,10 +2891,14 @@ implementation will be used." ;; Handle error buffer. (when (bufferp stderr) + (unless (tramp-get-remote-mknod-or-mkfifo v) + (tramp-error + v 'file-error "Stderr buffer `%s' not supported" stderr)) (with-current-buffer stderr (setq buffer-read-only nil)) ;; Create named pipe. - (tramp-send-command v (format "mknod %s p" tmpstderr)) + (tramp-send-command + v (format (tramp-get-remote-mknod-or-mkfifo v) tmpstderr)) ;; Create stderr process. (make-process :name (buffer-name stderr) @@ -2915,6 +2945,12 @@ implementation will be used." (setq p (tramp-get-connection-process v)) (process-put p 'remote-pid pid) (tramp-set-connection-property p "remote-pid" pid)) + ;; Disable carriage return to newline + ;; translation. This does not work on + ;; macOS, see Bug#50748. + (when (and (memq connection-type '(nil pipe)) + (not (tramp-check-remote-uname v "Darwin"))) + (tramp-send-command v "stty -icrnl")) ;; `tramp-maybe-open-connection' and ;; `tramp-send-command-and-read' could have ;; trashed the connection buffer. Remove this. @@ -2942,7 +2978,7 @@ implementation will be used." (ignore-errors (set-process-query-on-exit-flag p (null noquery)) (set-marker (process-mark p) (point))) - ;; Kill stderr process delete and named pipe. + ;; Kill stderr process and delete named pipe. (when (bufferp stderr) (add-function :after (process-sentinel p) @@ -2957,7 +2993,7 @@ implementation will be used." p))) ;; Save exit. - (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (if (string-prefix-p tramp-temp-buffer-name (buffer-name)) (ignore-errors (set-process-buffer p nil) (kill-buffer (current-buffer))) @@ -3039,7 +3075,7 @@ implementation will be used." ;; 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-p "=" elt) + (if (tramp-compat-string-search "=" elt) (setq env (append env `(,elt))) (setq uenv (cons elt uenv))))) (setenv-internal env "INSIDE_EMACS" (tramp-inside-emacs) 'keep) @@ -3200,7 +3236,7 @@ implementation will be used." (let (file-name-handler-alist (coding-system-for-write 'binary) (default-directory - (tramp-compat-temporary-file-directory))) + tramp-compat-temporary-file-directory)) (with-temp-file tmpfile (set-buffer-multibyte nil) (insert-buffer-substring (tramp-get-buffer v)) @@ -3248,7 +3284,7 @@ implementation will be used." (or (eq mustbenew 'excl) (not (y-or-n-p - (format "File %s exists; overwrite anyway? " filename))))) + (format "File %s exists; overwrite anyway?" filename))))) (tramp-error v 'file-already-exists filename)) (let ((file-locked (eq (file-locked-p lockname) t)) @@ -3293,8 +3329,7 @@ implementation will be used." ;; we use it always because this makes the logic ;; simpler. We must also set `temporary-file-directory', ;; because it could point to a remote directory. - (temporary-file-directory - (tramp-compat-temporary-file-directory)) + (temporary-file-directory tramp-compat-temporary-file-directory) (tmpfile (or tramp-temp-buffer-file-name (tramp-compat-make-temp-file filename)))) @@ -3387,7 +3422,7 @@ implementation will be used." ;; question is a tmp file anyway. (let ((coding-system-for-read 'binary) (default-directory - (tramp-compat-temporary-file-directory))) + tramp-compat-temporary-file-directory)) (insert-file-contents-literally tmpfile) (funcall loc-enc (point-min) (point-max))) @@ -3488,7 +3523,7 @@ implementation will be used." (tramp-compat-funcall 'unlock-file lockname)) (when (and (null noninteractive) - (or (eq visit t) (null visit) (stringp visit))) + (or (eq visit t) (string-or-null-p visit))) (tramp-message v 0 "Wrote %s" filename)) (run-hooks 'tramp-handle-write-region-hook))))) @@ -3979,15 +4014,12 @@ Returns the absolute file name of PROGNAME, if found, and nil otherwise. This function expects to be in the right *tramp* buffer." (with-current-buffer (tramp-get-connection-buffer vec) (let (result) - ;; Check whether the executable is in $PATH. "which(1)" does not + ;; Check whether the executable is in $PATH. "which(1)" does not ;; report always a correct error code; therefore we check the ;; number of words it returns. "SunOS 5.10" (and maybe "SunOS ;; 5.11") have problems with this command, we disable the call ;; therefore. - (unless (or ignore-path - (string-match-p - tramp-sunos-unames - (tramp-get-connection-property vec "uname" ""))) + (unless (or ignore-path (tramp-check-remote-uname vec tramp-sunos-unames)) (tramp-send-command vec (format "which \\%s | wc -w" progname)) (goto-char (point-min)) (if (looking-at-p "^\\s-*1$") @@ -4197,9 +4229,7 @@ file exists and nonzero exit status otherwise." ;; 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-p - tramp-sunos-unames - (tramp-get-connection-property vec "uname" ""))) + (tramp-check-remote-uname vec tramp-sunos-unames)) (or (tramp-find-executable vec "bash" (tramp-get-remote-path vec) t t) @@ -4308,7 +4338,7 @@ 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-p "^Darwin" uname) + (string-prefix-p "Darwin" uname) (cons 'utf-8-hfs 'utf-8-hfs)) (and (memq 'utf-8 (coding-system-list)) (string-match-p "utf-?8" (tramp-get-remote-locale vec)) @@ -4321,7 +4351,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-p "^Darwin" uname) 'mac 'unix))) + cs-encode (if (string-prefix-p "Darwin" uname) 'mac 'unix))) (tramp-send-command vec "(echo foo ; echo bar)" t) (goto-char (point-min)) (when (search-forward "\r" nil t) @@ -4371,7 +4401,7 @@ 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 ;; <https://stackoverflow.com/questions/3291692/irix-bash-shell-expands-expression-in-single-quotes-yet-shouldnt>. - (when (string-match-p "^IRIX64" uname) + (when (string-prefix-p "IRIX64" uname) (tramp-send-command vec "set +H" t)) ;; Disable tab expansion. @@ -4627,12 +4657,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-p "%s" cmd))) input) + (when (and input (not (tramp-compat-string-search "%s" cmd))) input) (if (eq output t) t nil) nil tramp-encoding-command-switch (concat - (if (string-match-p "%s" cmd) (format cmd input) cmd) + (if (tramp-compat-string-search "%s" cmd) (format cmd input) cmd) (if (stringp output) (concat " >" output) "")))) (defconst tramp-inline-compress-commands @@ -4883,6 +4913,8 @@ connection if a previous connection has died for some reason." (tramp-error vec 'file-error "`tramp-encoding-shell' not set")) (let* ((current-host tramp-system-name) (target-alist (tramp-compute-multi-hops vec)) + ;; Needed for `tramp-get-remote-null-device'. + (previous-hop nil) ;; We will apply `tramp-ssh-controlmaster-options' ;; only for the first hop. (options (tramp-ssh-controlmaster-options vec)) @@ -4896,7 +4928,7 @@ connection if a previous connection has died for some reason." ;; This must be done in order to avoid our file ;; name handler. (p (let ((default-directory - (tramp-compat-temporary-file-directory))) + tramp-compat-temporary-file-directory)) (apply #'start-process (tramp-get-connection-name vec) @@ -4995,6 +5027,8 @@ connection if a previous connection has died for some reason." hop 'tramp-login-args ?h (or l-host "") ?u (or l-user "") ?p (or l-port "") ?c (format-spec options (format-spec-make ?t tmpfile)) + ?n (concat + "2>" (tramp-get-remote-null-device previous-hop)) ?l (concat remote-shell " " extra-args " -i")) ;; A restricted shell does not allow "exec". (when r-shell '("&&" "exit" "||" "exit"))) @@ -5010,10 +5044,12 @@ connection if a previous connection has died for some reason." tramp-actions-before-shell (or connection-timeout tramp-connection-timeout)) (tramp-message - vec 3 "Found remote shell prompt on `%s'" l-host)) - ;; Next hop. - (setq options "" - target-alist (cdr target-alist))) + vec 3 "Found remote shell prompt on `%s'" l-host) + + ;; Next hop. + (setq options "" + target-alist (cdr target-alist) + previous-hop hop))) ;; Activate session timeout. (when (tramp-get-connection-property p "session-timeout" nil) @@ -5222,7 +5258,7 @@ Return ATTR." (when (stringp (car attr)) (aset (nth 8 attr) 0 ?l))) ;; Convert directory indication bit. - (when (string-match-p "^d" (nth 8 attr)) + (when (string-prefix-p "d" (nth 8 attr)) (setcar attr t)) ;; Convert symlink from `tramp-do-file-attributes-with-stat'. ;; Decode also multibyte string. @@ -5310,6 +5346,10 @@ Return ATTR." ;; Variables local to connection. +(defun tramp-check-remote-uname (vec regexp) + "Check whether REGEXP matches the connection property \"uname\"." + (string-match-p regexp (tramp-get-connection-property vec "uname" ""))) + (defun tramp-get-remote-path (vec) "Compile list of remote directories for PATH. Nonexistent directories are removed from spec." @@ -5534,8 +5574,7 @@ Nonexistent directories are removed from spec." (with-tramp-connection-property vec "stat" ;; stat on Solaris is buggy. We've got reports for "SunOS 5.10" ;; and "SunOS 5.11" so far. - (unless (string-match-p - tramp-sunos-unames (tramp-get-connection-property vec "uname" "")) + (unless (tramp-check-remote-uname vec tramp-sunos-unames) (tramp-message vec 5 "Finding a suitable `stat' command") (let ((result (tramp-find-executable vec "stat" (tramp-get-remote-path vec))) @@ -5770,11 +5809,28 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." (tramp-file-local-name tmpfile) (tramp-file-local-name tmpfile))) (delete-file tmpfile))))) +(defun tramp-get-remote-mknod-or-mkfifo (vec) + "Determine remote `mknod' or `mkfifo' command." + (with-tramp-connection-property vec "mknod-or-mkfifo" + (tramp-message vec 5 "Finding a suitable `mknod' or `mkfifo' command") + (let ((tmpfile (tramp-make-tramp-temp-name vec)) + command) + (prog1 + (or (and (setq command "mknod %s p") + (tramp-send-command-and-check + vec (format command (tramp-file-local-name tmpfile))) + command) + (and (setq command "mkfifo %s") + (tramp-send-command-and-check + vec (format command (tramp-file-local-name tmpfile))) + command)) + (delete-file tmpfile))))) + ;; Some predefined connection properties. (defun tramp-get-inline-compress (vec prop size) "Return the compress command related to PROP. -PROP is either `inline-compress' or `inline-decompress'. SIZE is -the length of the file to be compressed. +PROP is either `inline-compress' or `inline-decompress'. +SIZE is the length of the file to be compressed. If no corresponding command is found, nil is returned." (when (and (integerp tramp-inline-compress-start-size) @@ -5802,12 +5858,13 @@ function cell is returned to be applied on a buffer." (with-tramp-connection-property (tramp-get-process vec) prop (tramp-find-inline-encoding vec) (tramp-get-connection-property (tramp-get-process vec) prop nil))) - (prop1 (if (string-match-p "encoding" prop) + (prop1 (if (tramp-compat-string-search "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-p "remote" prop)) + (when (and coding (symbolp coding) + (tramp-compat-string-search "remote" prop)) (let ((name (symbol-name coding))) (while (string-match "-" name) (setq name (replace-match "_" nil t name))) @@ -5819,7 +5876,7 @@ function cell is returned to be applied on a buffer." ;; Return the value. (cond ((and compress (symbolp coding)) - (if (string-match-p "decompress" prop1) + (if (tramp-compat-string-search "decompress" prop1) `(lambda (beg end) (,coding beg end) (let ((coding-system-for-write 'binary) @@ -5838,16 +5895,16 @@ function cell is returned to be applied on a buffer." (,coding (point-min) (point-max))))) ((symbolp coding) coding) - ((and compress (string-match-p "decoding" prop)) + ((and compress (tramp-compat-string-search "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-p "local" prop) + ((and (tramp-compat-string-search "local" prop) (eq system-type 'windows-nt)) "(%s | \"%s\")") - ((string-match-p "local" prop) "(%s | %s)") + ((tramp-compat-string-search "local" prop) "(%s | %s)") (t "(%s | %s >%%s)")) coding compress)) (compress @@ -5855,14 +5912,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-p "local" prop) + (if (and (tramp-compat-string-search "local" prop) (eq system-type 'windows-nt)) "(%s <%%s | \"%s\")" "(%s <%%s | %s)") compress coding)) - ((string-match-p "decoding" prop) + ((tramp-compat-string-search "decoding" prop) (cond - ((string-match-p "local" prop) (format "%s" coding)) + ((tramp-compat-string-search "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 3d5be61d3f0..49f049d3f34 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -48,7 +48,7 @@ ;; Another guess. We might implement a better check later on. (tramp-case-insensitive t))))) -;; Add a default for `tramp-default-user-alist'. Rule: For the SMB method, +;; Add a default for `tramp-default-user-alist'. Rule: For the SMB method, ;; the anonymous user is chosen. ;;;###tramp-autoload (tramp--with-startup @@ -83,7 +83,7 @@ call, letting the SMB client use the default one." They are added to the `tramp-smb-program' call via \"--option '...'\". For example, if the deprecated SMB1 protocol shall be used, add to -this variable (\"client min protocol=NT1\") ." +this variable \"client min protocol=NT1\"." :group 'tramp :type '(repeat string) :version "28.1") @@ -376,7 +376,7 @@ arguments to pass to the OPERATION." (and (numberp ok-if-already-exists) (not (yes-or-no-p (format - "File %s already exists; make it a link anyway? " + "File %s already exists; make it a link anyway?" v2-localname))))) (tramp-error v2 'file-already-exists newname) (delete-file newname))) @@ -414,157 +414,176 @@ arguments to pass to the OPERATION." (defun tramp-smb-handle-copy-directory (dirname newname &optional keep-date parents copy-contents) "Like `copy-directory' for Tramp files." - (if copy-contents - ;; We must do it file-wise. - (tramp-run-real-handler - #'copy-directory (list dirname newname keep-date parents copy-contents)) - - (setq dirname (expand-file-name dirname) - newname (expand-file-name newname)) - (let ((t1 (tramp-tramp-file-p dirname)) - (t2 (tramp-tramp-file-p newname))) - (with-parsed-tramp-file-name (if t1 dirname newname) nil - (with-tramp-progress-reporter - v 0 (format "Copying %s to %s" dirname newname) - (unless (file-exists-p dirname) - (tramp-compat-file-missing v dirname)) - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-already-exists newname)) - (cond - ;; We must use a local temporary directory. - ((and t1 t2) - (let ((tmpdir (tramp-compat-make-temp-name))) - (unwind-protect - (progn - (make-directory tmpdir) - (copy-directory - dirname (file-name-as-directory tmpdir) keep-date 'parents) - (copy-directory - (expand-file-name (file-name-nondirectory dirname) tmpdir) - newname keep-date parents)) - (delete-directory tmpdir 'recursive)))) - - ;; We can copy recursively. - ;; TODO: Does not work reliably. - (nil ;(and (or t1 t2) (tramp-smb-get-cifs-capabilities v)) + (let ((t1 (tramp-tramp-file-p dirname)) + (t2 (tramp-tramp-file-p newname)) + target) + (with-parsed-tramp-file-name (if t1 dirname newname) nil + (unless (file-exists-p dirname) + (tramp-compat-file-missing v dirname)) + + ;; `copy-directory-create-symlink' exists since Emacs 28.1. + (if (and (bound-and-true-p copy-directory-create-symlink) + (setq target (file-symlink-p dirname)) + (tramp-equal-remote dirname newname)) + (make-symbolic-link + target + (if (directory-name-p newname) + (concat newname (file-name-nondirectory dirname)) newname) + t) + + (if copy-contents + ;; We must do it file-wise. + (tramp-run-real-handler + #'copy-directory + (list dirname newname keep-date parents copy-contents)) + + (setq dirname (expand-file-name dirname) + newname (expand-file-name newname)) + (with-tramp-progress-reporter + v 0 (format "Copying %s to %s" dirname newname) + (unless (file-exists-p dirname) + (tramp-compat-file-missing v dirname)) (when (and (file-directory-p newname) - (not (string-equal (file-name-nondirectory dirname) - (file-name-nondirectory newname)))) - (setq newname - (expand-file-name - (file-name-nondirectory dirname) newname)) - (if t2 (setq v (tramp-dissect-file-name newname)))) - (if (not (file-directory-p newname)) - (make-directory newname parents)) - - (let* ((share (tramp-smb-get-share v)) - (localname (file-name-as-directory - (tramp-compat-string-replace - "\\" "/" (tramp-smb-get-localname v)))) - (tmpdir (tramp-compat-make-temp-name)) - (args (list (concat "//" host "/" share) "-E")) - (options tramp-smb-options)) - - (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)))) - (while options + (not (directory-name-p newname))) + (tramp-error v 'file-already-exists newname)) + (cond + ;; We must use a local temporary directory. + ((and t1 t2) + (let ((tmpdir (tramp-compat-make-temp-name))) + (unwind-protect + (progn + (make-directory tmpdir) + (copy-directory + dirname (file-name-as-directory tmpdir) + keep-date 'parents) + (copy-directory + (expand-file-name (file-name-nondirectory dirname) tmpdir) + newname keep-date parents)) + (delete-directory tmpdir 'recursive)))) + + ;; We can copy recursively. + ;; TODO: Does not work reliably. + (nil ;(and (or t1 t2) (tramp-smb-get-cifs-capabilities v)) + (when (and (file-directory-p newname) + (not (string-equal (file-name-nondirectory dirname) + (file-name-nondirectory newname)))) + (setq newname + (expand-file-name + (file-name-nondirectory dirname) newname)) + (if t2 (setq v (tramp-dissect-file-name newname)))) + (if (not (file-directory-p newname)) + (make-directory newname parents)) + + (let* ((share (tramp-smb-get-share v)) + (localname (file-name-as-directory + (tramp-compat-string-replace + "\\" "/" (tramp-smb-get-localname v)))) + (tmpdir (tramp-compat-make-temp-name)) + (args (list (concat "//" host "/" share) "-E")) + (options tramp-smb-options)) + + (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)))) + (while options + (setq args + (append args `("--option" ,(format "%s" (car options)))) + options (cdr options))) (setq args - (append args `("--option" ,(format "%s" (car options)))) - options (cdr options))) - (setq args - (if t1 - ;; Source is remote. - (append args + (if t1 + ;; Source is remote. + (append args + (list "-D" (tramp-unquote-shell-quote-argument + localname) + "-c" (tramp-unquote-shell-quote-argument + "tar qc - *") + "|" "tar" "xfC" "-" + (tramp-unquote-shell-quote-argument + tmpdir))) + ;; Target is remote. + (append (list + "tar" "cfC" "-" + (tramp-unquote-shell-quote-argument dirname) + "." "|") + args (list "-D" (tramp-unquote-shell-quote-argument localname) "-c" (tramp-unquote-shell-quote-argument - "tar qc - *") - "|" "tar" "xfC" "-" - (tramp-unquote-shell-quote-argument - tmpdir))) - ;; Target is remote. - (append (list "tar" "cfC" "-" - (tramp-unquote-shell-quote-argument dirname) - "." "|") - args - (list "-D" (tramp-unquote-shell-quote-argument - localname) - "-c" (tramp-unquote-shell-quote-argument - "tar qx -"))))) - - (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)) - - (when t1 - ;; The smbclient tar command creates always - ;; complete paths. We must emulate the - ;; directory structure, and symlink to the real - ;; target. - (make-directory - (expand-file-name - ".." (concat tmpdir localname)) - 'parents) - (make-symbolic-link - newname (directory-file-name (concat tmpdir localname)))) - - ;; Use an asynchronous processes. By this, - ;; password can be handled. - (let* ((default-directory tmpdir) - (p (apply - #'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - tramp-smb-program args))) - - (tramp-message - v 6 "%s" (string-join (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-with-tar) - - (while (process-live-p p) - (sleep-for 0.1)) - (tramp-message v 6 "\n%s" (buffer-string)))) - - ;; Reset the transfer process properties. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") - (when t1 (delete-directory tmpdir 'recursive)))) - - ;; Handle KEEP-DATE argument. - (when keep-date - (tramp-compat-set-file-times - newname - (tramp-compat-file-attribute-modification-time - (file-attributes dirname)) - (unless ok-if-already-exists 'nofollow))) - - ;; Set the mode. - (unless keep-date - (set-file-modes newname (tramp-default-file-modes dirname))) - - ;; When newname did exist, we have wrong cached values. - (when t2 - (with-parsed-tramp-file-name newname nil - (tramp-flush-file-properties v localname)))) - - ;; We must do it file-wise. - (t - (tramp-run-real-handler - #'copy-directory (list dirname newname keep-date parents))))))))) + "tar qx -"))))) + + (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)) + + (when t1 + ;; The smbclient tar command creates always + ;; complete paths. We must emulate the + ;; directory structure, and symlink to the + ;; real target. + (make-directory + (expand-file-name + ".." (concat tmpdir localname)) + 'parents) + (make-symbolic-link + newname + (directory-file-name (concat tmpdir localname)))) + + ;; Use an asynchronous processes. By this, + ;; password can be handled. + (let* ((default-directory tmpdir) + (p (apply + #'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + tramp-smb-program args))) + + (tramp-message + v 6 "%s" (string-join (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-with-tar) + + (while (process-live-p p) + (sleep-for 0.1)) + (tramp-message v 6 "\n%s" (buffer-string)))) + + ;; Reset the transfer process properties. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + (when t1 (delete-directory tmpdir 'recursive)))) + + ;; Handle KEEP-DATE argument. + (when keep-date + (tramp-compat-set-file-times + newname + (tramp-compat-file-attribute-modification-time + (file-attributes dirname)) + (unless ok-if-already-exists 'nofollow))) + + ;; Set the mode. + (unless keep-date + (set-file-modes newname (tramp-default-file-modes dirname))) + + ;; When newname did exist, we have wrong cached values. + (when t2 + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-properties v localname)))) + + ;; We must do it file-wise. + (t + (tramp-run-real-handler + #'copy-directory (list dirname newname keep-date parents)))))))))) (defun tramp-smb-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -849,7 +868,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Check result. (when entry - (list (and (string-match-p "d" (nth 1 entry)) + (list (and (tramp-compat-string-search "d" (nth 1 entry)) t) ;0 file type -1 ;1 link count uid ;2 uid @@ -982,7 +1001,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (mapcar (lambda (x) (list - (if (string-match-p "d" (nth 1 x)) + (if (tramp-compat-string-search "d" (nth 1 x)) (file-name-as-directory (nth 0 x)) (nth 0 x)))) (tramp-smb-get-file-entries directory))))))) @@ -1021,7 +1040,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-p + (tramp-compat-string-search "w" (or (tramp-compat-file-attribute-modes (file-attributes filename)) "")) (let ((dir (file-name-directory filename))) @@ -1076,9 +1095,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Check for matching entries. (mapcar (lambda (x) - (when (string-match-p - (format "^%s" base) (nth 0 x)) - x)) + (when (string-match-p (format "^%s" base) (nth 0 x)) x)) entries) ;; We just need the only and only entry FILENAME. (list (assoc base entries))))) @@ -1088,14 +1105,14 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (sort entries (lambda (x y) - (if (string-match-p "t" switches) + (if (tramp-compat-string-search "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-p "F" switches) + (when (tramp-compat-string-search "F" switches) (mapc (lambda (x) (unless (zerop (length (car x))) @@ -1124,7 +1141,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-p "l" switches) + (when (tramp-compat-string-search "l" switches) (insert (format "%10s %3d %-8s %-8s %8s %s " @@ -1153,7 +1170,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-p "l" switches) + (when (and (tramp-compat-string-search "l" switches) (stringp (tramp-compat-file-attribute-type attr))) (insert " -> " (tramp-compat-file-attribute-type attr)))) @@ -1230,7 +1247,7 @@ component is used as the target of the symlink." (and (numberp ok-if-already-exists) (not (yes-or-no-p (format - "File %s already exists; make it a link anyway? " + "File %s already exists; make it a link anyway?" localname))))) (tramp-error v 'file-already-exists localname) (delete-file linkname))) @@ -1509,7 +1526,7 @@ component is used as the target of the symlink." (tramp-error v 'file-error "Error while changing file's mode %s" filename)))))) -;; We use BUFFER also as connection buffer during setup. Because of +;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once ;; connection has been setup. (defun tramp-smb-handle-start-file-process (name buffer program &rest args) @@ -1551,7 +1568,7 @@ component is used as the target of the symlink." ;; Save exit. (with-current-buffer (tramp-get-connection-buffer v) - (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (if (tramp-compat-string-search tramp-temp-buffer-name (buffer-name)) (progn (set-process-buffer (tramp-get-connection-process v) nil) (kill-buffer (current-buffer))) @@ -1586,7 +1603,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (or (eq mustbenew 'excl) (not (y-or-n-p - (format "File %s exists; overwrite anyway? " filename))))) + (format "File %s exists; overwrite anyway?" filename))))) (tramp-error v 'file-already-exists filename)) (let ((file-locked (eq (file-locked-p lockname) t)) @@ -1641,7 +1658,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." ;; The end. (when (and (null noninteractive) - (or (eq visit t) (null visit) (stringp visit))) + (or (eq visit t) (string-or-null-p visit))) (tramp-message v 0 "Wrote %s" filename)) (run-hooks 'tramp-handle-write-region-hook)))) @@ -1686,7 +1703,7 @@ If VEC has no cifs capabilities, exchange \"/\" by \"\\\\\"." localname))) -;; Share names of a host are cached. It is very unlikely that the +;; Share names of a host are cached. It is very unlikely that the ;; shares do change during connection. (defun tramp-smb-get-file-entries (directory) "Read entries which match DIRECTORY. @@ -1857,10 +1874,12 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." mode (or (match-string 1 line) "") mode (format "%s%s" - (if (string-match-p "D" mode) "d" "-") + (if (tramp-compat-string-search "D" mode) "d" "-") (mapconcat (lambda (_x) "") " " - (concat "r" (if (string-match-p "R" mode) "-" "w") "x"))) + (format + "r%sx" + (if (tramp-compat-string-search "R" mode) "-" "w")))) line (substring line 0 -6)) (cl-return)) @@ -1943,7 +1962,7 @@ If ARGUMENT is non-nil, use it as argument for ;; Otherwise, we must delete the connection cache, because ;; capabilities might have changed. (unless (or argument (processp p)) - (let ((default-directory (tramp-compat-temporary-file-directory)) + (let ((default-directory tramp-compat-temporary-file-directory) (command (concat tramp-smb-program " -V"))) (unless tramp-smb-version @@ -2030,7 +2049,10 @@ If ARGUMENT is non-nil, use it as argument for (let* ((coding-system-for-read nil) (process-connection-type tramp-process-connection-type) (p (let ((default-directory - (tramp-compat-temporary-file-directory))) + tramp-compat-temporary-file-directory) + (process-environment + (cons (concat "TERM=" tramp-terminal-type) + process-environment))) (apply #'start-process (tramp-get-connection-name vec) (tramp-get-connection-buffer vec) @@ -2181,5 +2203,7 @@ Removes smb prompt. Returns nil if an error message has appeared." ;; ;; * Try to remove the inclusion of dummy "" directory. Seems to be at ;; several places, especially in `tramp-smb-handle-insert-directory'. +;; +;; * Keep a separate connection process per share. ;;; tramp-smb.el ends here diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index c5b84a6e4e4..a1007863453 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -222,11 +222,14 @@ arguments to pass to the OPERATION." (defun tramp-sshfs-handle-insert-file-contents (filename &optional visit beg end replace) "Like `insert-file-contents' for Tramp files." - (let ((result - (insert-file-contents - (tramp-fuse-local-file-name filename) visit beg end replace))) - (when visit (setq buffer-file-name filename)) - (cons (expand-file-name filename) (cdr result)))) + (setq filename (expand-file-name filename)) + (let (signal-hook-function result) + (unwind-protect + (setq result + (insert-file-contents + (tramp-fuse-local-file-name filename) visit beg end replace)) + (when visit (setq buffer-file-name filename)) + (cons filename (cdr result))))) (defun tramp-sshfs-handle-process-file (program &optional infile destination display &rest args) @@ -292,7 +295,7 @@ arguments to pass to the OPERATION." (or (eq mustbenew 'excl) (not (y-or-n-p - (format "File %s exists; overwrite anyway? " filename))))) + (format "File %s exists; overwrite anyway?" filename))))) (tramp-error v 'file-already-exists filename)) (let ((file-locked (eq (file-locked-p lockname) t))) @@ -317,7 +320,7 @@ arguments to pass to the OPERATION." ;; The end. (when (and (null noninteractive) - (or (eq visit t) (null visit) (stringp visit))) + (or (eq visit t) (string-or-null-p visit))) (tramp-message v 0 "Wrote %s" filename)) (run-hooks 'tramp-handle-write-region-hook)))) @@ -346,30 +349,31 @@ connection if a previous connection has died for some reason." (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) ;; Set connection-local variables. - (tramp-set-connection-local-variables vec) - - ;; Create directory. - (unless (file-directory-p (tramp-fuse-mount-point vec)) - (make-directory (tramp-fuse-mount-point vec) 'parents)) - - (unless - (or (tramp-fuse-mounted-p vec) - (with-temp-buffer - (zerop - (apply - #'tramp-call-process - vec tramp-sshfs-program nil t nil - (tramp-fuse-mount-spec vec) - (tramp-fuse-mount-point vec) - (tramp-expand-args - vec 'tramp-mount-args - ?p (or (tramp-file-name-port vec) ""))))) - (tramp-error - vec 'file-error "Error mounting %s" (tramp-fuse-mount-spec vec)))) - - ;; Mark it as connected. - (tramp-set-connection-property - (tramp-get-connection-process vec) "connected" t))) + (tramp-set-connection-local-variables vec))) + + ;; Create directory. + (unless (file-directory-p (tramp-fuse-mount-point vec)) + (make-directory (tramp-fuse-mount-point vec) 'parents)) + + (unless + (or (tramp-fuse-mounted-p vec) + (with-temp-buffer + (zerop + (apply + #'tramp-call-process + vec tramp-sshfs-program nil t nil + (tramp-fuse-mount-spec vec) + (tramp-fuse-mount-point vec) + (tramp-expand-args + vec 'tramp-mount-args + ?p (or (tramp-file-name-port vec) "")))))) + (tramp-error + vec 'file-error "Error mounting %s" (tramp-fuse-mount-spec vec))) + + ;; Mark it as connected. + (add-to-list 'tramp-fuse-mount-points (tramp-file-name-unify vec)) + (tramp-set-connection-property + (tramp-get-connection-process vec) "connected" t) ;; In `tramp-check-cached-permissions', the connection properties ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index e4d90dde701..845f31d09b1 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -190,7 +190,7 @@ arguments to pass to the OPERATION." (and (numberp ok-if-already-exists) (not (yes-or-no-p (format - "File %s already exists; make it a link anyway? " + "File %s already exists; make it a link anyway?" v2-localname))))) (tramp-error v2 'file-already-exists newname) (delete-file newname))) @@ -464,8 +464,9 @@ the result will be a local, non-Tramp, file name." "Like `file-readable-p' for Tramp files." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-readable-p" - (tramp-sudoedit-send-command - v "test" "-r" (tramp-compat-file-name-unquote localname))))) + (or (tramp-handle-file-readable-p filename) + (tramp-sudoedit-send-command + v "test" "-r" (tramp-compat-file-name-unquote localname)))))) (defun tramp-sudoedit-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." @@ -597,6 +598,7 @@ the result will be a local, non-Tramp, file name." v (if parents "/" (file-name-directory localname))) (unless (tramp-sudoedit-send-command v (if parents '("mkdir" "-p") "mkdir") + "-m" (format "%#o" (default-file-modes)) (tramp-compat-file-name-unquote localname)) (tramp-error v 'file-error "Couldn't make directory %s" dir)))) @@ -631,7 +633,7 @@ component is used as the target of the symlink." (not (yes-or-no-p (format - "File %s already exists; make it a link anyway? " + "File %s already exists; make it a link anyway?" localname))))) (tramp-error v 'file-already-exists localname) (delete-file linkname))) @@ -817,6 +819,9 @@ in case of error, t otherwise." (tramp-compat-flatten-tree args)))) ;; We suppress the messages `Waiting for prompts from remote shell'. (tramp-verbose (if (= tramp-verbose 3) 2 tramp-verbose)) + ;; The password shall be cached also in case of "emacs -Q". + ;; See `tramp-process-actions'. + (tramp-cache-read-persistent-data t) ;; We do not want to save the password. auth-source-save-behavior) (tramp-message vec 6 "%s" (string-join (process-command p) " ")) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 4db0b2e6723..a8972ce69e8 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -183,7 +183,7 @@ See the variable `tramp-encoding-shell' for more information." :version "24.1" :type '(choice (const nil) string)) -;; Since Emacs 26.1, `system-name' can return `nil' at build time if +;; Since Emacs 26.1, `system-name' can return nil at build time if ;; Emacs is compiled with "--no-build-details". We do expect it to be ;; a string. (Bug#44481) (defconst tramp-system-name (or (system-name) "") @@ -586,8 +586,7 @@ Sometimes the prompt is reported to look like \"login as:\"." (defcustom tramp-shell-prompt-pattern ;; Allow a prompt to start right after a ^M since it indeed would be - ;; displayed at the beginning of the line (and Zsh uses it). This - ;; regexp works only for GNU Emacs. + ;; displayed at the beginning of the line (and Zsh uses it). ;; Allow also [] style prompts. They can appear only during ;; connection initialization; Tramp redefines the prompt afterwards. (concat "\\(?:^\\|\r\\)" @@ -698,11 +697,26 @@ The regexp should match at end of buffer." :version "27.1" :type 'regexp) -;; Yubikey requires the user physically to touch the device with their -;; finger. We must tell it to the user. -(defcustom tramp-yubikey-regexp - "Confirm user presence for key .*" - "Regular expression matching yubikey confirmation message. +;; A security key requires the user physically to touch the device +;; with their finger. We must tell it to the user. +;; Added in OpenSSH 8.2. I've tested it with yubikey. +(defcustom tramp-security-key-confirm-regexp + "^\r*Confirm user presence for key .*[\r\n]*" + "Regular expression matching security key confirmation message. +The regexp should match at end of buffer." + :version "28.1" + :type 'regexp) + +(defcustom tramp-security-key-confirmed-regexp + "^\r*User presence confirmed[\r\n]*" + "Regular expression matching security key confirmation message. +The regexp should match at end of buffer." + :version "28.1" + :type 'regexp) + +(defcustom tramp-security-key-timeout-regexp + "^\r*sign_and_send_pubkey: signing failed for .*[\r\n]*" + "Regular expression matching security key timeout message. The regexp should match at end of buffer." :version "28.1" :type 'regexp) @@ -847,7 +861,7 @@ Used in `tramp-make-tramp-file-name'.") (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 . "[[:alnum:]-]+") @@ -1257,14 +1271,14 @@ this variable to be set as well." :type '(choice (const nil) integer)) ;; Logging in to a remote host normally requires obtaining a pty. But -;; Emacs on macOS has process-connection-type set to nil by default, +;; Emacs on macOS has `process-connection-type' set to nil by default, ;; so on those systems Tramp doesn't obtain a pty. Here, we allow ;; for an override of the system default. (defcustom tramp-process-connection-type t "Overrides `process-connection-type' for connections from Tramp. Tramp binds `process-connection-type' to the value given here before opening a connection to a remote host." - :type '(choice (const nil) (const t) (const pty))) + :type '(choice (const nil) (const t) (const pipe) (const pty))) (defcustom tramp-connection-timeout 60 "Defines the max time to wait for establishing a connection (in seconds). @@ -1290,7 +1304,7 @@ let-bind this variable." ;; "getconf PATH" yields: ;; HP-UX: /usr/bin:/usr/ccs/bin:/opt/ansic/bin:/opt/langtools/bin:/opt/fortran/bin ;; Solaris: /usr/xpg4/bin:/usr/ccs/bin:/usr/bin:/opt/SUNWspro/bin -;; GNU/Linux (Debian, Suse, RHEL): /bin:/usr/bin +;; GNU/Linux (Debian, Suse, RHEL, Cygwin, MINGW64): /bin:/usr/bin ;; FreeBSD, DragonFly: /usr/bin:/bin:/usr/sbin:/sbin: - beware trailing ":"! ;; FreeBSD 12.1, Darwin: /usr/bin:/bin:/usr/sbin:/sbin ;; IRIX64: /usr/bin @@ -1312,9 +1326,9 @@ tilde expansion, all directory names starting with \"~\" will be ignored. the command \"getconf PATH\". It is recommended to use this entry on head of this list, because these are the default directories for POSIX compatible commands. On remote hosts which -do not offer the getconf command (like cygwin), the value -\"/bin:/usr/bin\" is used instead. This entry is represented in -the list by the special value `tramp-default-remote-path'. +do not offer the getconf command, the value \"/bin:/usr/bin\" is +used instead. This entry is represented in the list by the +special value `tramp-default-remote-path'. `Private Directories' are the settings of the $PATH environment, as given in your `~/.profile'. This entry is represented in @@ -1436,16 +1450,24 @@ If nil, return `tramp-default-port'." (put #'tramp-file-name-port-or-default 'tramp-suppress-trace t) +(defun tramp-file-name-unify (vec) + "Unify VEC by removing localname and hop from `tramp-file-name' structure. +Objects returned by this function compare `equal' if they refer to the +same connection. Make a copy in order to avoid side effects." + (when (tramp-file-name-p vec) + (setq vec (copy-tramp-file-name vec)) + (setf (tramp-file-name-localname vec) nil + (tramp-file-name-hop vec) nil)) + vec) + +(put #'tramp-file-name-unify 'tramp-suppress-trace t) + ;; Comparison 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) - (string-equal (tramp-file-name-method vec1) - (tramp-file-name-method vec2)) - (string-equal (tramp-file-name-user-domain vec1) - (tramp-file-name-user-domain vec2)) - (string-equal (tramp-file-name-host-port vec1) - (tramp-file-name-host-port vec2)))) + (equal (tramp-file-name-unify vec1) + (tramp-file-name-unify vec2)))) (defun tramp-get-method-parameter (vec param) "Return the method parameter PARAM. @@ -1618,7 +1640,8 @@ default values are used." (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))) + (or (and v (not (tramp-compat-string-search + "%h" (tramp-file-name-host v))) (tramp-file-name-host v)) tramp-default-host))) (setq method (tramp-find-method method user host) @@ -1735,6 +1758,9 @@ the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." tramp-postfix-host-format localname))) +(set-advertised-calling-convention + #'tramp-make-tramp-file-name '(vec &optional localname hop) "27.1") + (defun tramp-make-tramp-hop-name (vec) "Construct a Tramp hop name from VEC." (replace-regexp-in-string @@ -1884,7 +1910,7 @@ The outline level is equal to the verbosity of the Tramp message." ;; `(custom-declare-variable outline-minor-mode-prefix ...)' ;; raises on error in `(outline-mode)', we don't want to see it ;; in the traces. - (let ((default-directory (tramp-compat-temporary-file-directory))) + (let ((default-directory tramp-compat-temporary-file-directory)) (outline-mode)) (setq-local outline-level 'tramp-debug-outline-level) (setq-local font-lock-keywords @@ -1903,7 +1929,7 @@ The outline level is equal to the verbosity of the Tramp message." "Get the debug file name for VEC." (expand-file-name (tramp-compat-string-replace "/" " " (tramp-debug-buffer-name vec)) - (tramp-compat-temporary-file-directory))) + tramp-compat-temporary-file-directory)) (put #'tramp-get-debug-file-name 'tramp-suppress-trace t) @@ -1914,7 +1940,7 @@ The outline level is equal to the verbosity of the Tramp message." (put #'tramp-trace-buffer-name 'tramp-suppress-trace t) (defvar tramp-trace-functions nil - "A list of non-Tramp functions to be trace with tramp-verbose > 10.") + "A list of non-Tramp functions to be traced with `tramp-verbose' > 10.") (defun tramp-debug-message (vec fmt-string &rest arguments) "Append message to debug buffer of VEC. @@ -1945,7 +1971,8 @@ ARGUMENTS to actually emit the message (if applicable)." (dolist (elt (append - (mapcar #'intern (all-completions "tramp-" obarray 'functionp)) + (mapcar + #'intern (all-completions "tramp-" obarray #'functionp)) tramp-trace-functions)) (unless (get elt 'tramp-suppress-trace) (trace-function-background elt)))) @@ -1966,7 +1993,7 @@ ARGUMENTS to actually emit the message (if applicable)." (if (not btf) (setq fn "") (and (symbolp btf) (setq fn (symbol-name btf)) - (or (not (string-match-p "^tramp" fn)) + (or (not (string-prefix-p "tramp" fn)) (get btf 'tramp-suppress-trace)) (setq fn nil)) (setq btn (1+ btn)))) @@ -2063,8 +2090,7 @@ VEC-OR-PROC identifies the connection to use, SIGNAL is the signal identifier to be raised, remaining arguments passed to `tramp-message'. Finally, signal SIGNAL is raised with FMT-STRING and ARGUMENTS." - (let ((inhibit-message t) - signal-hook-function) + (let (signal-hook-function) (tramp-backtrace vec-or-proc) (unless arguments ;; FMT-STRING could be just a file name, as in @@ -2174,9 +2200,10 @@ the resulting error message." ;; `custom-initialize-*' functions provoke `void-variable' errors. ;; We don't want to see them in the backtrace. (unless (eq error-symbol 'void-variable) - (tramp-error - (car tramp-current-connection) error-symbol - (mapconcat (lambda (x) (format "%s" x)) data " ")))) + (let ((inhibit-message t)) + (tramp-error + (car tramp-current-connection) error-symbol + (mapconcat (lambda (x) (format "%s" x)) data " "))))) (put #'tramp-signal-hook-function 'tramp-suppress-trace t) @@ -2218,7 +2245,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-p message (or (current-message) "")) + (when (tramp-compat-string-search message (or (current-message) "")) (tramp-compat-progress-reporter-update reporter value suffix)))) (defmacro with-tramp-progress-reporter (vec level message &rest body) @@ -2332,7 +2359,7 @@ Example: (unless (and (functionp (nth 0 (car v))) (cond ;; Windows registry. - ((string-match-p "^HKEY_CURRENT_USER" (nth 1 (car v))) + ((string-prefix-p "HKEY_CURRENT_USER" (nth 1 (car v))) (and (memq system-type '(cygwin windows-nt)) (zerop (tramp-call-process @@ -2364,7 +2391,7 @@ For definition of that list see `tramp-set-completion-function'." ;; Inodes don't exist for some file systems. Therefore we must ;; generate virtual ones. Used in `find-buffer-visiting'. The method -;; applied might be not so efficient (Ange-FTP uses hashes). But +;; applied might be not so efficient (Ange-FTP uses hashes). But ;; performance isn't the major issue given that file transfer will ;; take time. (defvar tramp-inodes 0 @@ -2571,7 +2598,7 @@ Fall back to normal file name handler if no Tramp file name handler exists." ;; the bug#9114 for which it was added doesn't ;; clarify the core of the problem. (let ((default-directory - (tramp-compat-temporary-file-directory)) + tramp-compat-temporary-file-directory) file-name-handler-alist) (autoload-do-load sf foreign))) ;; (tramp-message @@ -2806,6 +2833,15 @@ not in completion mode." "Like `file-name-all-completions' for partial Tramp files." (let ((fullname (tramp-drop-volume-letter (expand-file-name filename directory))) + ;; When `tramp-syntax' is `simplified', we need a default method. + (tramp-default-method + (and (zerop (length tramp-postfix-method-format)) + tramp-default-method)) + (tramp-default-method-alist + (and (zerop (length tramp-postfix-method-format)) + tramp-default-method-alist)) + tramp-default-user tramp-default-user-alist + tramp-default-host tramp-default-host-alist hop result result1) ;; Suppress hop from completion. @@ -2884,7 +2920,7 @@ not in completion mode." ;; I misuse a little bit the `tramp-file-name' structure in order to ;; handle completion possibilities for partial methods / user names / ;; host names. Return value is a list of `tramp-file-name' structures -;; according to possible completions. If "localname" is non-nil it +;; according to possible completions. If "localname" is non-nil it ;; means there shouldn't be a completion anymore. ;; Expected results: @@ -2991,8 +3027,7 @@ remote host and localname (filename on remote host)." "Return all method completions for PARTIAL-METHOD." (mapcar (lambda (method) - (and method - (string-match-p (concat "^" (regexp-quote partial-method)) method) + (and method (string-prefix-p (or partial-method "") method) (tramp-completion-make-tramp-file-name method nil nil nil))) (mapcar #'car tramp-methods))) @@ -3004,8 +3039,7 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." (cond ((and partial-user partial-host) - (if (and host - (string-match-p (concat "^" (regexp-quote partial-host)) host) + (if (and host (string-prefix-p partial-host host) (string-equal partial-user (or user partial-user))) (setq user partial-user) (setq user nil @@ -3013,16 +3047,12 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." (partial-user (setq host nil) - (unless - (and user - (string-match-p (concat "^" (regexp-quote partial-user)) user)) + (unless (and user (string-prefix-p partial-user user)) (setq user nil))) (partial-host (setq user nil) - (unless - (and host - (string-match-p (concat "^" (regexp-quote partial-host)) host)) + (unless (and host (string-prefix-p partial-host host)) (setq host nil))) (t (setq user nil @@ -3072,7 +3102,7 @@ User is always nil." User is always nil." ;; On Windows, there are problems in completion when ;; `default-directory' is remote. - (let ((default-directory (tramp-compat-temporary-file-directory))) + (let ((default-directory tramp-compat-temporary-file-directory)) (when (file-readable-p filename) (with-temp-buffer (insert-file-contents-literally filename) @@ -3126,7 +3156,7 @@ User is always nil." User is always nil." ;; On Windows, there are problems in completion when ;; `default-directory' is remote. - (let* ((default-directory (tramp-compat-temporary-file-directory)) + (let* ((default-directory tramp-compat-temporary-file-directory) (files (and (file-directory-p dirname) (directory-files dirname)))) (cl-loop for f in files @@ -3248,10 +3278,18 @@ User is always nil." (defun tramp-handle-access-file (filename string) "Like `access-file' for Tramp files." - (unless (file-readable-p (file-truename filename)) - (tramp-compat-file-missing - (tramp-dissect-file-name filename) - (format "%s: %s" string filename)))) + (setq filename (file-truename filename)) + (with-parsed-tramp-file-name filename v + (if (file-exists-p filename) + (unless + (funcall + (if (file-directory-p filename) + #'file-accessible-directory-p #'file-readable-p) + filename) + (tramp-error + v 'file-error (format "%s: Permission denied, %s" string filename))) + (tramp-compat-file-missing + v (format "%s: No such file or directory, %s" string filename))))) (defun tramp-handle-add-name-to-file (filename newname &optional ok-if-already-exists) @@ -3270,7 +3308,7 @@ User is always nil." (and (numberp ok-if-already-exists) (not (yes-or-no-p (format - "File %s already exists; make it a link anyway? " + "File %s already exists; make it a link anyway?" localname))))) (tramp-error v 'file-already-exists newname) (delete-file newname))) @@ -3360,7 +3398,7 @@ User is always nil." ;; 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))) + (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)))))))) @@ -3445,8 +3483,8 @@ User is always nil." (or ;; Maybe there is a default value. (tramp-get-method-parameter v 'tramp-case-insensitive) - ;; There isn't. So we must check, in case there's a connection already. - (and (file-remote-p filename nil 'connected) + ;; There isn't. So we must check, in case there's a connection already. + (and (let ((non-essential t)) (tramp-connectable-p v)) (with-tramp-connection-property v "case-insensitive" (ignore-errors (with-tramp-progress-reporter v 5 "Checking case-insensitive" @@ -3541,6 +3579,17 @@ User is always nil." (tramp-compat-file-attribute-modification-time (file-attributes file1)))))) +(defun tramp-handle-file-readable-p (filename) + "Like `file-readable-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-readable-p" + (or (tramp-check-cached-permissions v ?r) + ;; `tramp-check-cached-permissions' doesn't handle symbolic + ;; links. + (when-let ((symlink (file-symlink-p filename))) + (and (stringp symlink) + (file-readable-p (concat (file-remote-p filename) symlink)))))))) + (defun tramp-handle-file-regular-p (filename) "Like `file-regular-p' for Tramp files." (and (file-exists-p filename) @@ -3666,6 +3715,7 @@ User is always nil." #'find-backup-file-name (list filename))) ;; Protect against security hole. (when (and (not tramp-allow-unsafe-temporary-files) + (not backup-inhibited) (file-in-directory-p (car result) temporary-file-directory) (zerop (or (tramp-compat-file-attribute-user-id (file-attributes filename 'integer)) @@ -3675,7 +3725,7 @@ User is always nil." (yes-or-no-p (concat "Backup file on local temporary directory, " - "do you want to continue? "))))) + "do you want to continue?"))))) (tramp-error v 'file-error "Unsafe backup file name")))))) (defun tramp-handle-insert-directory @@ -3699,7 +3749,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-p "l" switches) + (unless (tramp-compat-string-search "l" switches) (save-excursion (goto-char (point-min)) (while (setq start @@ -3723,7 +3773,8 @@ User is always nil." (with-parsed-tramp-file-name filename nil (unwind-protect (if (not (file-exists-p filename)) - (tramp-compat-file-missing v filename) + (let ((tramp-verbose (if visit 0 tramp-verbose))) + (tramp-compat-file-missing v filename)) (with-tramp-progress-reporter v 3 (format-message "Inserting `%s'" filename) @@ -3825,7 +3876,7 @@ User is always nil." (delete-file (tramp-make-tramp-file-name v remote-copy 'nohop)))) ;; Result. - (cons (expand-file-name filename) (cdr result))))) + (cons filename (cdr result))))) (defun tramp-get-lock-file (file) "Read lockfile info of FILE. @@ -3886,6 +3937,7 @@ Return nil when there is no lockfile." ;; Protect against security hole. (with-parsed-tramp-file-name file nil (when (and (not tramp-allow-unsafe-temporary-files) + create-lockfiles (file-in-directory-p lockname temporary-file-directory) (zerop (or (tramp-compat-file-attribute-user-id (file-attributes file 'integer)) @@ -3895,11 +3947,12 @@ Return nil when there is no lockfile." (yes-or-no-p (concat "Lock file on local temporary directory, " - "do you want to continue? "))))) + "do you want to continue?"))))) (tramp-error v 'file-error "Unsafe lock file name"))) ;; Do the lock. - (let (create-lockfiles signal-hook-function) + (let ((tramp-verbose 0) + create-lockfiles signal-hook-function) (condition-case nil (make-symbolic-link info lockname 'ok-if-already-exists) (error @@ -4083,20 +4136,21 @@ substitution. SPEC-LIST is a list of char/value pairs used for "An alternative `make-process' implementation for Tramp files." (when args (with-parsed-tramp-file-name (expand-file-name default-directory) nil - (let ((default-directory (tramp-compat-temporary-file-directory)) + (let ((default-directory tramp-compat-temporary-file-directory) (name (plist-get args :name)) (buffer (plist-get args :buffer)) (command (plist-get args :command)) (coding (plist-get args :coding)) (noquery (plist-get args :noquery)) - (connection-type (plist-get args :connection-type)) + (connection-type + (or (plist-get args :connection-type) process-connection-type)) (filter (plist-get args :filter)) (sentinel (plist-get args :sentinel)) (stderr (plist-get args :stderr))) (unless (stringp name) (signal 'wrong-type-argument (list #'stringp name))) - (unless (or (null buffer) (bufferp buffer) (stringp buffer)) - (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (or (bufferp buffer) (string-or-null-p buffer)) + (signal 'wrong-type-argument (list #'bufferp buffer))) (unless (consp command) (signal 'wrong-type-argument (list #'consp command))) (unless (or (null coding) @@ -4105,9 +4159,11 @@ substitution. SPEC-LIST is a list of char/value pairs used for (memq (car coding) coding-system-list) (memq (cdr coding) coding-system-list))) (signal 'wrong-type-argument (list #'symbolp coding))) - (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (when (eq connection-type t) + (setq connection-type 'pty)) + (unless (memq connection-type '(nil pipe pty)) (signal 'wrong-type-argument (list #'symbolp connection-type))) - (unless (or (null filter) (functionp filter)) + (unless (or (null filter) (eq filter t) (functionp filter)) (signal 'wrong-type-argument (list #'functionp filter))) (unless (or (null sentinel) (functionp sentinel)) (signal 'wrong-type-argument (list #'functionp sentinel))) @@ -4121,14 +4177,14 @@ substitution. SPEC-LIST is a list of char/value pairs used for (generate-new-buffer tramp-temp-buffer-name))) (env (mapcar (lambda (elt) - (when (string-match-p "=" elt) elt)) + (when (tramp-compat-string-search "=" elt) elt)) tramp-remote-process-environment)) ;; We use as environment the difference to toplevel ;; `process-environment'. (env (dolist (elt process-environment env) (when (and - (string-match-p "=" elt) + (tramp-compat-string-search "=" elt) (not (member elt (default-toplevel-value 'process-environment)))) @@ -4186,7 +4242,12 @@ substitution. SPEC-LIST is a list of char/value pairs used for :name name :buffer buffer :command (append `(,login-program) login-args command) :coding coding :noquery noquery :connection-type connection-type - :filter filter :sentinel sentinel :stderr stderr)) + :sentinel sentinel :stderr stderr)) + ;; Set filter. Prior Emacs 29.1, it doesn't work reliable + ;; to provide it as `make-process' argument when filter is + ;; t. See Bug#51177. + (when filter + (set-process-filter p filter)) (tramp-message v 6 "%s" (string-join (process-command p) " ")) p)))))) @@ -4251,13 +4312,13 @@ support symbolic links." ((eq async-shell-command-buffer 'confirm-kill-process) ;; If will kill a process, query first. (if (yes-or-no-p - "A command is running in the default buffer. Kill it? ") + "A command is running in the default buffer. Kill it?") (kill-process p) (tramp-user-error p "Shell command in progress"))) ((eq async-shell-command-buffer 'confirm-new-buffer) ;; If will create a new buffer, query first. (if (yes-or-no-p - "A command is running in the default buffer. Use a new buffer? ") + "A command is running in the default buffer. Use a new buffer?") (setq output-buffer (generate-new-buffer bname)) (tramp-user-error p "Shell command in progress"))) ((eq async-shell-command-buffer 'new-buffer) @@ -4266,7 +4327,7 @@ support symbolic links." ((eq async-shell-command-buffer 'confirm-rename-buffer) ;; If will rename the buffer, query first. (if (yes-or-no-p - "A command is running in the default buffer. Rename it? ") + "A command is running in the default buffer. Rename it?") (progn (with-current-buffer output-buffer (rename-uniquely)) @@ -4469,7 +4530,7 @@ of." (or (eq mustbenew 'excl) (not (y-or-n-p - (format "File %s exists; overwrite anyway? " filename))))) + (format "File %s exists; overwrite anyway?" filename))))) (tramp-error v 'file-already-exists filename)) (let ((file-locked (eq (file-locked-p lockname) t)) @@ -4530,7 +4591,7 @@ of." ;; The end. (when (and (null noninteractive) - (or (eq visit t) (null visit) (stringp visit))) + (or (eq visit t) (string-or-null-p visit))) (tramp-message v 0 "Wrote %s" filename)) (run-hooks 'tramp-handle-write-region-hook)))) @@ -4588,14 +4649,16 @@ of." ;; prompts from the remote host. See the variable ;; `tramp-actions-before-shell' for usage of these functions. +(defvar tramp-process-action-regexp nil + "The regexp used to invoke an action in `tramp-process-one-action'.") + (defun tramp-action-login (_proc vec) "Send the login name." (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)))))))) + (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) @@ -4605,15 +4668,14 @@ of." (defun tramp-action-password (proc vec) "Query the user for a password." (with-current-buffer (process-buffer proc) - (let ((enable-recursive-minibuffers t) - (case-fold-search t)) + (let ((case-fold-search t)) ;; Let's check whether a wrong password has been sent already. ;; Sometimes, the process returns a new password request ;; immediately after rejecting the previous (wrong) one. (unless (tramp-get-connection-property vec "first-password-request" nil) (tramp-clear-passwd vec)) (goto-char (point-min)) - (tramp-check-for-regexp proc tramp-password-prompt-regexp) + (tramp-check-for-regexp proc tramp-process-action-regexp) (tramp-message vec 3 "Sending %s" (match-string 1)) ;; We don't call `tramp-send-string' in order to hide the ;; password from the debug buffer and the traces. @@ -4637,14 +4699,13 @@ of." Send \"yes\" to remote process on confirmation, abort otherwise. See also `tramp-action-yn'." (save-window-excursion - (let ((enable-recursive-minibuffers t)) - (pop-to-buffer (tramp-get-connection-buffer vec)) - (unless (yes-or-no-p (match-string 0)) - (kill-process proc) - (throw 'tramp-action 'permission-denied)) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) - (tramp-send-string vec (concat "yes" tramp-local-end-of-line)))) + (pop-to-buffer (tramp-get-connection-buffer vec)) + (unless (yes-or-no-p (match-string 0)) + (kill-process proc) + (throw 'tramp-action 'permission-denied)) + (with-current-buffer (tramp-get-connection-buffer vec) + (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-send-string vec (concat "yes" tramp-local-end-of-line))) t) (defun tramp-action-yn (proc vec) @@ -4652,14 +4713,13 @@ See also `tramp-action-yn'." Send \"y\" to remote process on confirmation, abort otherwise. See also `tramp-action-yesno'." (save-window-excursion - (let ((enable-recursive-minibuffers t)) - (pop-to-buffer (tramp-get-connection-buffer vec)) - (unless (y-or-n-p (match-string 0)) - (kill-process proc) - (throw 'tramp-action 'permission-denied)) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) - (tramp-send-string vec (concat "y" tramp-local-end-of-line)))) + (pop-to-buffer (tramp-get-connection-buffer vec)) + (unless (y-or-n-p (match-string 0)) + (kill-process proc) + (throw 'tramp-action 'permission-denied)) + (with-current-buffer (tramp-get-connection-buffer vec) + (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-send-string vec (concat "y" tramp-local-end-of-line))) t) (defun tramp-action-terminal (_proc vec) @@ -4678,16 +4738,27 @@ The terminal type can be configured with `tramp-terminal-type'." (tramp-send-string vec tramp-local-end-of-line) t) -(defun tramp-action-show-and-confirm-message (_proc vec) +(defun tramp-action-show-and-confirm-message (proc vec) "Show the user a message for confirmation. -Wait, until the user has entered RET." - (save-window-excursion - (let ((enable-recursive-minibuffers t) - (stimers (with-timeout-suspend))) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string)) - (pop-to-buffer (current-buffer))) - (read-string "Press ENTER to continue") +Wait, until the connection buffer changes." + (with-current-buffer (process-buffer proc) + (let ((stimers (with-timeout-suspend)) + (cursor-in-echo-area t) + set-message-function clear-message-function) + ;; Silence byte compiler. + (ignore set-message-function clear-message-function) + (tramp-message vec 6 "\n%s" (buffer-string)) + (tramp-check-for-regexp proc tramp-process-action-regexp) + (with-temp-message (replace-regexp-in-string "[\r\n]" "" (match-string 0)) + ;; Hide message in buffer. + (narrow-to-region (point-max) (point-max)) + ;; Wait for new output. + (while (not (tramp-compat-ignore-error 'file-error + (tramp-wait-for-regexp + proc 0.1 tramp-security-key-confirmed-regexp))) + (when (tramp-check-for-regexp proc tramp-security-key-timeout-regexp) + (throw 'tramp-action 'timeout)) + (redisplay 'force))) ;; Reenable the timers. (with-timeout-unsuspend stimers))) t) @@ -4729,6 +4800,7 @@ Wait, until the user has entered RET." "Wait for output from the shell and perform one action. See `tramp-process-actions' for the format of ACTIONS." (let ((case-fold-search t) + tramp-process-action-regexp found todo item pattern action) (while (not found) ;; Reread output once all actions have been performed. @@ -4737,7 +4809,8 @@ See `tramp-process-actions' for the format of ACTIONS." (setq todo actions) (while todo (setq item (pop todo) - pattern (format "\\(%s\\)\\'" (symbol-value (nth 0 item))) + tramp-process-action-regexp (symbol-value (nth 0 item)) + pattern (format "\\(%s\\)\\'" tramp-process-action-regexp) action (nth 1 item)) (tramp-message vec 5 "Looking for regexp \"%s\" from remote shell" pattern) @@ -4780,7 +4853,8 @@ performed successfully. Any other value means an error." (save-restriction (with-tramp-progress-reporter proc 3 "Waiting for prompts from remote shell" - (let (exit) + (let ((enable-recursive-minibuffers t) + exit) (if timeout (with-timeout (timeout (setq exit 'timeout)) (while (not exit) @@ -5327,7 +5401,7 @@ This handles also chrooted environments, which are not regarded as local." ;; The local temp directory must be writable for the other user. (file-writable-p (tramp-make-tramp-file-name - vec (tramp-compat-temporary-file-directory) 'nohop)) + vec tramp-compat-temporary-file-directory 'nohop)) ;; On some systems, chown runs only for root. (or (zerop (user-uid)) (zerop (tramp-get-remote-uid vec 'integer)))))) @@ -5389,7 +5463,8 @@ this file, if that variable is non-nil." ;; Create directory. (unless (or (null tramp-auto-save-directory) (file-exists-p tramp-auto-save-directory)) - (make-directory tramp-auto-save-directory t)) + (with-file-modes #o0700 + (make-directory tramp-auto-save-directory t))) (let ((system-type (if (and (stringp tramp-auto-save-directory) @@ -5418,6 +5493,7 @@ this file, if that variable is non-nil." (setq result (tramp-run-real-handler #'make-auto-save-file-name nil)) ;; Protect against security hole. (when (and (not tramp-allow-unsafe-temporary-files) + auto-save-default (file-in-directory-p result temporary-file-directory) (zerop (or (tramp-compat-file-attribute-user-id (file-attributes filename 'integer)) @@ -5427,7 +5503,7 @@ this file, if that variable is non-nil." (yes-or-no-p (concat "Autosave file on local temporary directory, " - "do you want to continue? "))))) + "do you want to continue?"))))) (tramp-error v 'file-error "Unsafe autosave file name")))))) (defun tramp-subst-strs-in-string (alist string) @@ -5467,7 +5543,7 @@ 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)) + (let ((default-directory tramp-compat-temporary-file-directory) (process-environment (default-toplevel-value 'process-environment)) (destination (if (eq destination t) (current-buffer) destination)) (vec (or vec (car tramp-current-connection))) @@ -5501,7 +5577,7 @@ are written with verbosity of 6." 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)) + (let ((default-directory tramp-compat-temporary-file-directory) (process-environment (default-toplevel-value 'process-environment)) (buffer (if (eq buffer t) (current-buffer) buffer)) result) @@ -5531,7 +5607,7 @@ are written with verbosity of 6." "Call `process-lines' on the local host. If an error occurs, it returns nil. Traces are written with verbosity of 6." - (let ((default-directory (tramp-compat-temporary-file-directory)) + (let ((default-directory tramp-compat-temporary-file-directory) (process-environment (default-toplevel-value 'process-environment)) (vec (or vec (car tramp-current-connection))) result) @@ -5559,6 +5635,9 @@ verbosity of 6." (string-prefix-p comm process-name) (throw 'result t))))))) +;; When calling "emacs -Q", `auth-source-search' won't be called. If +;; you want to debug exactly this case, call "emacs -Q --eval '(setq +;; tramp-cache-read-persistent-data t)'" instead. (defun tramp-read-passwd (proc &optional prompt) "Read a password from user (compat function). Consults the auth-source package. @@ -5567,7 +5646,7 @@ Invokes `password-read' if available, `read-passwd' else." ;; `exec-path' contains a relative file name like ".", it ;; could happen that the "gpg" command is not found. So we ;; adapt `default-directory'. (Bug#39389, Bug#39489) - (default-directory (tramp-compat-temporary-file-directory)) + (default-directory tramp-compat-temporary-file-directory) (case-fold-search t) (key (tramp-make-tramp-file-name ;; In tramp-sh.el, we must use "password-vector" due to @@ -5633,6 +5712,10 @@ Invokes `password-read' if available, `read-passwd' else." ;; Else, get the password interactively w/o cache. (read-passwd pw-prompt)) + ;; Workaround. Prior Emacs 28.1, auth-source has saved + ;; empty passwords. See discussion in Bug#50399. + (when (zerop (length auth-passwd)) + (setq tramp-password-save-function nil)) (tramp-set-connection-property v "first-password-request" nil))) ;; Reenable the timers. diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index e6cf4c6ac53..8baf0780c28 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -7,7 +7,7 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.5.1 +;; Version: 2.5.2-pre ;; Package-Requires: ((emacs "25.1")) ;; Package-Type: multi ;; URL: https://www.gnu.org/software/tramp/ @@ -29,7 +29,7 @@ ;;; Commentary: -;; Convenience functions around the Tramp version. Partly generated +;; Convenience functions around the Tramp version. Partly generated ;; during Tramp configuration. ;;; Code: @@ -40,7 +40,7 @@ ;; ./configure" to change them. ;;;###tramp-autoload -(defconst tramp-version "2.5.1" +(defconst tramp-version "2.5.2-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -76,7 +76,7 @@ ;; Check for Emacs version. (let ((x (if (not (string-lessp emacs-version "25.1")) "ok" - (format "Tramp 2.5.1 is not fit for %s" + (format "Tramp 2.5.2-pre is not fit for %s" (replace-regexp-in-string "\n" "" (emacs-version)))))) (unless (string-equal "ok" x) (error "%s" x))) diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el index 4baa657c0a5..d14d382aac3 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el @@ -79,10 +79,10 @@ ;; GNU FTP Mirror List from https://www.gnu.org/order/ftp.html [mirrors "https://ftp.gnu.org/pub/gnu/" "https://ftpmirror.gnu.org"]) - ("GNU Project Home Page" . "www.gnu.org") + ("GNU Project Website" . "www.gnu.org") ;; Emacs. - ("Emacs Home Page" . + ("Emacs Website" . "www.gnu.org/software/emacs/emacs.html") ("Savannah Emacs page" . "savannah.gnu.org/projects/emacs") diff --git a/lisp/net/zeroconf.el b/lisp/net/zeroconf.el index d5da73bd857..98be0e0158e 100644 --- a/lisp/net/zeroconf.el +++ b/lisp/net/zeroconf.el @@ -104,7 +104,7 @@ (require 'dbus) (defvar zeroconf-debug nil - "Write messages during service discovery") + "Write messages during service discovery.") (defconst zeroconf-service-avahi "org.freedesktop.Avahi" "The D-Bus name used to talk to Avahi.") @@ -375,7 +375,7 @@ type used when registering FUNCTION." (defun zeroconf-get-service (name type) "Return the service description of service NAME as list. NAME must be a string. The service must be of service type -TYPE. The resulting list has the format +TYPE. The resulting list has the format (INTERFACE PROTOCOL NAME TYPE DOMAIN FLAGS)." ;; Due to the service browser, all known services are kept in @@ -387,7 +387,7 @@ TYPE. The resulting list has the format (defun zeroconf-resolve-service (service) "Return all service attributes SERVICE as list. NAME must be a string. The service must be of service type -TYPE. The resulting list has the format +TYPE. The resulting list has the format (INTERFACE PROTOCOL NAME TYPE DOMAIN HOST APROTOCOL ADDRESS PORT TXT FLAGS)." (let* ((name (zeroconf-service-name service)) |