diff --git a/etc/DEVEL.HUMOR b/etc/DEVEL.HUMOR index 6db69bb4b58..bd51845cb11 100644 --- a/etc/DEVEL.HUMOR +++ b/etc/DEVEL.HUMOR @@ -188,3 +188,19 @@ wouldn't worry about it too much." "Kind of late, but thanks for letting us know. I've just revoked your write access to the repository for the obvious safety reasons," -- Bastien Guerry and Stefan Monnier + +---------------------------------------------------------------------- + + "I should have known better than to think I could be right and you +wrong about some Emacs code I've just started looking at. Sorry about +that." + + "No problem. It's one of the many joys of working on a code base +that's up to almost 40 years old: First you have to figure out what +the (no doubt smart) programmer meant to achieve with the code, and +then try to figure out whether it ever even did that, and then whether +it's still working the same way, and then whether it's still relevant +due to changes elsewhere, and then finally whether it can be improved +without breaking odd edge cases on obscure systems you don't have +access to. 🙃" + -- Ignacio Casso and Lars Ingebrigtsen diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 8937df26017..e59a9723509 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -3226,7 +3226,8 @@ non-nil SPECS arg must be an alist with `search-query-spec' and (if (gnus-server-server-name) (list (list (gnus-server-server-name))) (seq-group-by - (lambda (elt) (gnus-group-server elt)) + (lambda (elt) (gnus-method-to-server + (gnus-find-method-for-group elt))) (or gnus-group-marked (if (gnus-group-group-name) (list (gnus-group-group-name)) @@ -3277,7 +3278,8 @@ non-nil SPECS arg must be an alist with `search-query-spec' and (if (gnus-server-server-name) (list (list (gnus-server-server-name))) (seq-group-by - (lambda (elt) (gnus-group-server elt)) + (lambda (elt) (gnus-method-to-server + (gnus-find-method-for-group elt))) (or gnus-group-marked (if (gnus-group-group-name) (list (gnus-group-group-name)) diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index bf88abae76c..4babe9f96f0 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el @@ -762,6 +762,9 @@ the files in ARTLIST by that search key.") (generate-new-buffer " *gnus-search-"))) (cl-call-next-method engine slots)) +(defclass gnus-search-nnselect (gnus-search-engine) + nil) + (defclass gnus-search-imap (gnus-search-engine) ((literal-plus :initarg :literal-plus @@ -907,13 +910,15 @@ quirks.") (define-obsolete-variable-alias 'nnir-method-default-engines 'gnus-search-default-engines "28.1") -(defcustom gnus-search-default-engines '((nnimap . gnus-search-imap)) +(defcustom gnus-search-default-engines '((nnimap . gnus-search-imap) + (nnselect . gnus-search-nnselect)) "Alist of default search engines keyed by server method." :version "26.1" :type `(repeat (cons (choice (const nnimap) (const nntp) (const nnspool) (const nneething) (const nndir) (const nnmbox) (const nnml) (const nnmh) (const nndraft) - (const nnfolder) (const nnmaildir)) + (const nnfolder) (const nnmaildir) + (const nnselect)) (choice ,@(mapcar (lambda (el) (list 'const (intern (car el)))) @@ -1010,6 +1015,33 @@ Responsible for handling and, or, and parenthetical expressions.") unseen all old new or not) "Known IMAP search keys.") +(autoload 'nnselect-categorize "nnselect") +(autoload 'nnselect-get-artlist "nnselect" nil nil 'macro) +(autoload 'ids-by-group "nnselect") +;; nnselect interface +(cl-defmethod gnus-search-run-search ((_engine gnus-search-nnselect) + _srv query-spec groups) + (let ((artlist [])) + (dolist (group groups) + (let* ((gnus-newsgroup-selection (nnselect-get-artlist group)) + (group-spec + (nnselect-categorize + (mapcar 'car + (ids-by-group + (number-sequence 1 + (length gnus-newsgroup-selection)))) + (lambda (x) + (gnus-group-server x))))) + (setq artlist + (vconcat artlist + (seq-intersection + gnus-newsgroup-selection + (gnus-search-run-query + (list (cons 'search-query-spec query-spec) + (cons 'search-group-spec group-spec)))))))) + artlist)) + + ;; imap interface (cl-defmethod gnus-search-run-search ((engine gnus-search-imap) srv query groups) @@ -2155,7 +2187,8 @@ article came from is also searched." (read-from-minibuffer "Query: " nil gnus-search-minibuffer-map nil 'gnus-search-history))) - (cons 'raw arg))) + (cons 'raw + (or (gnus-nnselect-group-p (gnus-group-group-name)) arg)))) (provide 'gnus-search) ;;; gnus-search.el ends here diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index f8a0c33d4e5..f5be477d26d 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -47,7 +47,8 @@ ;;; Setup: (require 'gnus-art) -(require 'gnus-search) +(autoload 'gnus-search-run-query "gnus-search") +(autoload 'gnus-search-server-to-engine "gnus-search") (eval-when-compile (require 'cl-lib)) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 75e6b7179b0..85cd2d9bc1e 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -1364,6 +1364,24 @@ connection if a previous connection has died for some reason." `(:application tramp :protocol ,tramp-adb-method) 'tramp-adb-connection-local-default-shell-profile)) +;; `shell-mode' tries to open remote files like "/adb::~/.history". +;; This fails, because the tilde cannot be expanded. Tell +;; `tramp-handle-expand-file-name' to tolerate this. +(defun tramp-adb-tolerate-tilde (orig-fun) + "Advice for `shell-mode' to tolerate tilde in remote file names." + (let ((tramp-tolerate-tilde + (or tramp-tolerate-tilde + (equal (file-remote-p default-directory 'method) + tramp-adb-method)))) + (funcall orig-fun))) + +(add-function + :around (symbol-function #'shell-mode) #'tramp-adb-tolerate-tilde) +(add-hook 'tramp-adb-unload-hook + (lambda () + (remove-function + (symbol-function #'shell-mode) #'tramp-adb-tolerate-tilde))) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-adb 'force))) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index d3634b0cc25..23290de685e 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -1151,6 +1151,10 @@ file names." (replace-match (tramp-get-connection-property v "default-location" "~") nil t localname 1)))) + ;; Tilde expansion is not possible. + (when (and (not tramp-tolerate-tilde) + (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)) + (tramp-error v 'file-error "Cannot expand tilde in file `%s'" name)) (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) ;; We do not pass "/..". @@ -1168,7 +1172,7 @@ file names." ;; Do normal `expand-file-name' (this does "/./" and "/../"), ;; unless there are tilde characters in file name. (tramp-make-tramp-file-name - v (if (string-match-p "\\`~" localname) + v (if (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) localname (tramp-run-real-handler #'expand-file-name (list localname))))))) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 72837793de4..664dbc31b14 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -55,7 +55,8 @@ ;; These are for remote processes. (tramp-login-program "ssh") (tramp-login-args (("-q")("-l" "%u") ("-p" "%p") - ("-e" "none") ("%h") ("%l"))) + ("-e" "none") ("-t" "-t") + ("%h") ("%l"))) (tramp-direct-async t) (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) @@ -411,6 +412,24 @@ connection if a previous connection has died for some reason." (with-tramp-connection-property vec "gid-string" (tramp-get-local-gid 'string))) +;; `shell-mode' tries to open remote files like "/sshfs:user@host:~/.history". +;; This fails, because the tilde cannot be expanded. Tell +;; `tramp-handle-expand-file-name' to tolerate this. +(defun tramp-sshfs-tolerate-tilde (orig-fun) + "Advice for `shell-mode' to tolerate tilde in remote file names." + (let ((tramp-tolerate-tilde + (or tramp-tolerate-tilde + (equal (file-remote-p default-directory 'method) + tramp-sshfs-method)))) + (funcall orig-fun))) + +(add-function + :around (symbol-function #'shell-mode) #'tramp-sshfs-tolerate-tilde) +(add-hook 'tramp-sshfs-unload-hook + (lambda () + (remove-function + (symbol-function #'shell-mode) #'tramp-sshfs-tolerate-tilde))) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-sshfs 'force))) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index f93ca7601aa..32712efb3ea 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3458,6 +3458,10 @@ User is always nil." (if (file-directory-p dir) dir (file-name-directory dir)) nil (tramp-flush-directory-properties v localname))) +(defvar tramp-tolerate-tilde nil + "Indicator, that not expandable tilde shall be tolerated. +Let-bind it when necessary.") + (defun tramp-handle-expand-file-name (name &optional dir) "Like `expand-file-name' for Tramp files." ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". @@ -3475,7 +3479,8 @@ User is always nil." (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) ;; Tilde expansion is not possible. - (when (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + (when (and (not tramp-tolerate-tilde) + (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)) (tramp-error v 'file-error "Cannot expand tilde in file `%s'" name)) ;; Do not keep "/..". (when (string-match-p "^/\\.\\.?$" localname) @@ -3486,7 +3491,9 @@ User is always nil." (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)))))))) + (if (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + localname + (tramp-run-real-handler #'expand-file-name (list localname))))))))) (defun tramp-handle-file-accessible-directory-p (filename) "Like `file-accessible-directory-p' for Tramp files."