diff options
Diffstat (limited to 'lisp/gnus')
70 files changed, 5136 insertions, 3200 deletions
diff --git a/lisp/gnus/ChangeLog.2 b/lisp/gnus/ChangeLog.2 index 2f5dd22930e..533ceb84bf1 100644 --- a/lisp/gnus/ChangeLog.2 +++ b/lisp/gnus/ChangeLog.2 @@ -3378,7 +3378,7 @@ * gnus-async.el (gnus-asynchronous): Move defcustom of gnus-asynchronous away from defgroup of gnus-asynchronous. - This seems to fix an intermittant error in which loading gnus-async + This seems to fix an intermittent error in which loading gnus-async fails to define gnus-asynchronous (the variable). * gnus-sum.el: Concur with Steve Young, 5th argument to 'load' is @@ -7096,7 +7096,7 @@ * nnimap.el (nnimap-callback-callback-function): (nnimap-callback-buffer): Remove, these cannot be global but must be embedded into the callback. - (nnimap-make-callback): New. Embedd article number, callback and + (nnimap-make-callback): New. Embed article number, callback and buffer in function. (nnimap-callback, nnimap-request-article-part): Update. @@ -8031,7 +8031,7 @@ (message-xpost-fup2-header, message-xpost-insert-note) (message-xpost-fup2, message-reduce-to-to-cc): New functions adopted from message-utils.el. Add functions to the keymap, mode - describtion and menu. + description and menu. (message-change-subject, message-xpost-fup2): Signal error if current header is empty. (message-xpost-insert-note): Change insert position. @@ -8612,7 +8612,7 @@ 2002-06-11 Simon Josefsson <jas@extundo.com> * gnus-int.el (gnus-request-move-article): Agent expire article if - successfuly moved. + successfully moved. 2002-06-11 Niklas Morberg <niklas.morberg@axis.com> @@ -9073,7 +9073,7 @@ 2002-04-13 Josh Huber <huber@alum.wpi.edu> - * mml-sec.el (mml-secure-message): Change to support arbritrary + * mml-sec.el (mml-secure-message): Change to support arbitrary modes. * mml-sec.el (mml-secure-message-encrypt-(smime|pgp|pgpmime)): changed to support "signencrypt" mode. diff --git a/lisp/gnus/ChangeLog.3 b/lisp/gnus/ChangeLog.3 index 70eaeb510ac..582c9bd10b7 100644 --- a/lisp/gnus/ChangeLog.3 +++ b/lisp/gnus/ChangeLog.3 @@ -170,7 +170,7 @@ 2015-02-09 Lars Ingebrigtsen <larsi@gnus.org> * mm-decode.el (mm-convert-shr-links): Don't overwrite the faces from - shr, beacause that breaks folding. + shr, because that breaks folding. (mm-shr): Don't shorten the width when using fonts. 2015-02-05 Teodor Zlatanov <tzz@lifelogs.com> @@ -596,7 +596,7 @@ 2014-06-05 Katsumi Yamaoka <yamaoka@jpl.org> - * gnus-art.el (gnus-article-edit-part): Don't modifiy markers. + * gnus-art.el (gnus-article-edit-part): Don't modify markers. (gnus-article-read-summary-keys): Don't bug out when there is no article in the summary buffer. (gnus-mime-buttonize-attachments-in-header): @@ -1318,7 +1318,7 @@ 2013-08-06 Jan Tatarik <jan.tatarik@gmail.com> * gnus-icalendar.el (gnus-icalendar-event-from-ical): Replace pcase - with cond for backwards compatability. + with cond for backwards compatibility. 2013-08-06 Katsumi Yamaoka <yamaoka@jpl.org> @@ -2221,7 +2221,7 @@ 2013-04-04 Katsumi Yamaoka <yamaoka@jpl.org> - * mml.el (mml-minibuffer-read-description): Use `default' insted of + * mml.el (mml-minibuffer-read-description): Use `default' instead of `initial-input' for the argument name. Suggested by Stefan Monnier <monnier@iro.umontreal.ca>. @@ -5541,7 +5541,7 @@ (registry-prune-hard): Use it. * gnus-registry.el (gnus-registry-fixup-registry): Set prune-factor to - 0.1 expicitly. + 0.1 explicitly. 2011-05-13 Glenn Morris <rgm@gnu.org> @@ -8758,7 +8758,7 @@ * shr.el (shr-generic): The text nodes should be text, not :text. - * nnir.el (nnir-search-engine): Ressurect variable, since it's used + * nnir.el (nnir-search-engine): Resurrect variable, since it's used later in the file. 2010-10-30 Andrew Cohen <cohen@andy.bu.edu> @@ -9481,7 +9481,7 @@ nil. * gnus-start.el (gnus-get-unread-articles): Require gnus-agent before - bidning gnus-agent variables. + binding gnus-agent variables. * shr.el (shr-render-td): Use a cache for the table rendering function to avoid getting an exponential rendering behavior in nested tables. @@ -11849,7 +11849,7 @@ 2010-08-13 Teodor Zlatanov <tzz@lifelogs.com> - Doc fixes and keep unknown groups (ammended for nunion bug fix). + Doc fixes and keep unknown groups (amended for nunion bug fix). * gnus-sync.el: Fix docs. (gnus-sync-save): Keep unknown groups in `gnus-sync-newsrc-loader'. @@ -18925,7 +18925,7 @@ * message.el: Autoload gmm-image-load-path. (message-tool-bar-retro): Prepend "gnus/" subdirectory to some icon file names. Use old Emacs 21 "mail_send.xpm" icon for - consitency. + consistency. * gmm-utils.el (gmm-image-load-path): Also search in "../etc/images". Don't set gmm-image-load-path if we don't find @@ -19523,7 +19523,7 @@ * nnml.el: Don't require gnus-bcklg. Autoload it. (nnml-use-compressed-files, nnml-save-mail): Support other - comression programs such as bzip2. + compression programs such as bzip2. 2005-12-17 Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -21227,7 +21227,7 @@ (nntp-with-open-group): Allow debugging. * nnheader.el (mail-header-set-extra): Make into a function - because I just could't understand how to quote the list properly. + because I just couldn't understand how to quote the list properly. * dns.el (query-dns-cached): New function. @@ -24966,7 +24966,7 @@ functions as needing (default), or not needing, gnus-convert-old-newsrc's "backup before upgrading warning". (gnus-convert-converter-needs-prompt): Tests whether the user - should be protected from potentially irreversable changes by the + should be protected from potentially irreversible changes by the function. * legacy-gnus-agent.el: New. Provides converters that are only diff --git a/lisp/gnus/deuglify.el b/lisp/gnus/deuglify.el index 82dbbab5e0d..647f643c962 100644 --- a/lisp/gnus/deuglify.el +++ b/lisp/gnus/deuglify.el @@ -266,21 +266,21 @@ "\\(On \\|Am \\)?\\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),[^,]+, " "Regular expression matching the beginning of an attribution line that should be cut off." :version "22.1" - :type 'string + :type 'regexp :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-deuglify-attrib-verb-regexp "wrote\\|writes\\|says\\|schrieb\\|schreibt\\|meinte\\|skrev\\|a Γ©crit\\|schreef\\|escribiΓ³" "Regular expression matching the verb used in an attribution line." :version "22.1" - :type 'string + :type 'regexp :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-deuglify-attrib-end-regexp ": *\\|\\.\\.\\." "Regular expression matching the end of an attribution line." :version "22.1" - :type 'string + :type 'regexp :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-display-hook nil @@ -403,9 +403,9 @@ NODISPLAY is non-nil, don't redisplay the article buffer." (gnus-with-article-buffer (article-goto-body) (when (re-search-forward - (concat "^[" cite-marks " \t]*--* ?[^-]+ [^-]+ ?--*\\s *\n" + (concat "^[" cite-marks " \t]*--*[^-]+ [^-]+--*\\s *\n" "[^\n:]+:[ \t]*\\([^\n]+\\)\n" - "\\([^\n:]+:[ \t]*[^\n]+\n\\)+") + "\\([^\n:]+:[^\n]+\n\\)+") nil t) (gnus-kill-all-overlays) (replace-match "\\1 wrote:\n") diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el index 2df098bc0bf..6d24b409ed0 100644 --- a/lisp/gnus/gmm-utils.el +++ b/lisp/gnus/gmm-utils.el @@ -168,9 +168,9 @@ ARGS are passed to `message'." (defcustom gmm-tool-bar-style (if (and (boundp 'tool-bar-mode) tool-bar-mode - (memq (display-visual-class) - (list 'static-gray 'gray-scale - 'static-color 'pseudo-color))) + (not (memq (display-visual-class) + (list 'static-gray 'gray-scale + 'static-color 'pseudo-color)))) 'gnome 'retro) "Preferred tool bar style." diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index cf705ae5dc1..76c2904eaf0 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -603,11 +603,22 @@ manipulated as follows: (gnus)) ;;;###autoload +(defun gnus-child-unplugged (&optional arg) + "Read news as a child unplugged." + (interactive "P") + (setq gnus-plugged nil) + (gnus arg nil 'child)) + +;;;###autoload (defun gnus-slave-unplugged (&optional arg) - "Read news as a slave unplugged." + "Read news as a child unplugged." (interactive "P") (setq gnus-plugged nil) - (gnus arg nil 'slave)) + (gnus arg nil 'child)) +(make-obsolete 'gnus-slave-unplugged 'gnus-child-unplugged "28.1") + + + ;;;###autoload (defun gnus-agentize () @@ -799,7 +810,7 @@ be a select method." (let ((gnus-command-method method) (gnus-agent nil)) (when (file-exists-p (gnus-agent-lib-file "flags")) - (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*")) + (set-buffer (gnus-get-buffer-create " *Gnus Agent flag synchronize*")) (erase-buffer) (nnheader-insert-file-contents (gnus-agent-lib-file "flags")) (cond ((null gnus-plugged) @@ -1293,7 +1304,7 @@ downloaded into the agent." ;; gnus doesn't waste resources trying to fetch them. ;; NOTE: I don't do this for smaller gaps (< 100) as I don't - ;; want to modify the local file everytime someone restarts + ;; want to modify the local file every time someone restarts ;; gnus. The small gap will cause a tiny performance hit ;; when gnus tries, and fails, to retrieve the articles. ;; Still that should be smaller than opening a buffer, @@ -3923,7 +3934,7 @@ If REREAD is not nil, downloaded articles are marked as unread." (mm-with-unibyte-buffer (nnheader-insert-file-contents file) (nnheader-remove-body) - (setq header (nnheader-parse-naked-head))) + (setq header (nnheader-parse-head t))) (setf (mail-header-number header) (car downloaded)) (if nov-arts (let ((key (concat "^" (int-to-string (car nov-arts)) @@ -4022,11 +4033,11 @@ If REREAD is not nil, downloaded articles are marked as unread." (list (list (if (listp reread) reread - (delq nil (mapcar (function (lambda (c) - (cond ((eq reread t) - (car c)) - ((cdr c) - (car c))))) + (delq nil (mapcar (lambda (c) + (cond ((eq reread t) + (car c)) + ((cdr c) + (car c)))) gnus-agent-article-alist))) 'del '(read))) gnus-command-method) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 6b9610d3121..1efc1d6f7d9 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -274,6 +274,7 @@ This can also be a list of the above values." If it is a string, the command will be executed in a sub-shell asynchronously. The compressed face will be piped to this command." :type '(choice string + (const :tag "None" nil) (function-item gnus-display-x-face-in-from) function) :version "27.1" @@ -534,6 +535,13 @@ that the symbol of the saver function, which is specified by :group 'gnus-article-saving :type 'regexp) +(defcustom gnus-global-groups nil + "Groups that should be considered like \"news\" groups. +This means that images will be automatically loaded, for instance." + :type '(repeat string) + :version "28.1" + :group 'gnus-article) + ;; Note that "Rmail format" is mbox since Emacs 23, but Babyl before. (defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail "A function to save articles in your favorite format. @@ -2161,7 +2169,9 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (interactive) (save-excursion (when (article-goto-body) - (let ((inhibit-read-only t)) + (require 'ansi-color) + (let ((inhibit-read-only t) + (ansi-color-context-region nil)) (ansi-color-apply-on-region (point) (point-max)))))) (defun gnus-article-treat-unfold-headers () @@ -2303,21 +2313,27 @@ long lines if and only if arg is positive." "\n") (put-text-property start (point) 'gnus-decoration 'header))))) -(defun article-fill-long-lines () - "Fill lines that are wider than the window width." - (interactive) +(defun article-fill-long-lines (&optional width) + "Fill lines that are wider than the window width or `fill-column'. +If WIDTH (interactively, the numeric prefix), use that as the +fill width." + (interactive "P") (save-excursion - (let ((inhibit-read-only t) - (width (window-width (get-buffer-window (current-buffer))))) + (let* ((inhibit-read-only t) + (window-width (window-width (get-buffer-window (current-buffer)))) + (width (if width + (prefix-numeric-value width) + (min fill-column window-width)))) (save-restriction (article-goto-body) (let ((adaptive-fill-mode nil)) ;Why? -sm (while (not (eobp)) (end-of-line) - (when (>= (current-column) (min fill-column width)) + (when (>= (current-column) width) (narrow-to-region (min (1+ (point)) (point-max)) (point-at-bol)) - (let ((goback (point-marker))) + (let ((goback (point-marker)) + (fill-column width)) (fill-paragraph nil) (goto-char (marker-position goback))) (widen)) @@ -4406,6 +4422,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is "e" gnus-article-read-summary-keys "\C-d" gnus-article-read-summary-keys + "\C-c\C-f" gnus-summary-mail-forward "\M-*" gnus-article-read-summary-keys "\M-#" gnus-article-read-summary-keys "\M-^" gnus-article-read-summary-keys @@ -5833,6 +5850,7 @@ all parts." "" "...")) (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle) (buffer-size))) + (help-echo "mouse-2: toggle the MIME part; down-mouse-3: more options") gnus-tmp-type-long b e) (when (string-match ".*/" gnus-tmp-name) (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name))) @@ -5841,6 +5859,19 @@ all parts." (concat "; " gnus-tmp-name)))) (unless (equal gnus-tmp-description "") (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) + (when (and (zerop gnus-tmp-length) + ;; Only nnimap supports partial fetches so far. + nnimap-fetch-partial-articles + (string-match "^nnimap\\+" gnus-newsgroup-name)) + (setq gnus-tmp-type-long + (concat + gnus-tmp-type-long + (substitute-command-keys + (concat "\\<gnus-summary-mode-map> (not downloaded, " + "\\[gnus-summary-show-complete-article] to fetch.)")))) + (setq help-echo + (concat "Type \\[gnus-summary-show-complete-article] " + "to download complete article. " help-echo))) (setq b (point)) (gnus-eval-format gnus-mime-button-line-format gnus-mime-button-line-format-alist @@ -5859,8 +5890,7 @@ all parts." 'keymap gnus-mime-button-map 'face gnus-article-button-face 'follow-link t - 'help-echo - "mouse-2: toggle the MIME part; down-mouse-3: more options"))) + 'help-echo help-echo))) (defvar gnus-displaying-mime nil) @@ -6001,6 +6031,7 @@ If nil, don't show those extra buttons." (defun gnus-mime-display-single (handle) (let ((type (mm-handle-media-type handle)) (ignored gnus-ignored-mime-types) + (mm-inline-font-lock (gnus-visual-p 'article-highlight 'highlight)) (not-attachment t) display text) (catch 'ignored @@ -6664,7 +6695,7 @@ not have a face in `gnus-article-boring-faces'." (interactive "P") (gnus-article-check-buffer) (let ((nosaves - '("q" "Q" "r" "\C-c\C-f" "m" "a" "f" "WDD" "WDW" + '("q" "Q" "r" "m" "a" "f" "WDD" "WDW" "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" "=" "^" "\M-^" "|")) (nosave-but-article @@ -7065,6 +7096,7 @@ If given a prefix, show the hidden text instead." (gnus-backlog-enter-article group article (current-buffer))) (when (and gnus-agent + gnus-agent-eagerly-store-articles (gnus-agent-group-covered-p group)) (gnus-agent-store-article article group))) (setq result 'article)) @@ -7120,7 +7152,8 @@ If given a prefix, show the hidden text instead." "Allows images in newsgroups to be shown, blocks images in all other groups." (if (or (gnus-news-group-p group) - (gnus-member-of-valid 'global group)) + (gnus-member-of-valid 'global group) + (member group gnus-global-groups)) ;; Block nothing in news groups. nil ;; Block everything anywhere else. @@ -7708,6 +7741,15 @@ positives are possible." 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1) ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>" 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1) + ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)... + ("<URL: *\\([^\n<>]*\\)>" + 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) + ;; RFC 2396 (2.4.3., delims) ... + ("\"URL: *\\([^\n\"]*\\)\"" + 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) + ;; Raw URLs. + (gnus-button-url-regexp + 0 (>= gnus-button-browse-level 0) browse-url-button-open-url 0) ;; The following entries may lead to many false positives so don't enable ;; them by default (use a high button level). ("/\\([a-z][-a-z0-9]+\\.el\\)\\>[^.?]" @@ -7731,15 +7773,6 @@ positives are possible." ;; Unlike the other regexps we really have to require quoting ;; here to determine where it ends. 1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3) - ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)... - ("<URL: *\\([^\n<>]*\\)>" - 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) - ;; RFC 2396 (2.4.3., delims) ... - ("\"URL: *\\([^\n\"]*\\)\"" - 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) - ;; Raw URLs. - (gnus-button-url-regexp - 0 (>= gnus-button-browse-level 0) browse-url-button-open-url 0) ;; man pages ("\\b\\([a-z][a-z]+([1-9])\\)\\W" 0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3)) @@ -8323,6 +8356,7 @@ url is put as the `gnus-button-url' overlay property on the button." (and (match-end 6) (list (string-to-number (match-string 6 address)))))))) (defun gnus-url-parse-query-string (query &optional downcase) + (declare (obsolete message-parse-mailto-url "28.1")) (let (retval pairs cur key val) (setq pairs (split-string query "&")) (while pairs @@ -8342,31 +8376,8 @@ url is put as the `gnus-button-url' overlay property on the button." (defun gnus-url-mailto (url) ;; Send mail to someone - (setq url (replace-regexp-in-string "\n" " " url)) - (when (string-match "mailto:/*\\(.*\\)" url) - (setq url (substring url (match-beginning 1) nil))) - (let* ((args (gnus-url-parse-query-string - (if (string-match "^\\?" url) - (substring url 1) - (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url) - (concat "to=" (match-string 1 url) "&" - (match-string 2 url)) - (concat "to=" url))))) - (subject (cdr-safe (assoc "subject" args))) - func) - (gnus-msg-mail) - (while args - (setq func (intern-soft (concat "message-goto-" (downcase (caar args))))) - (if (fboundp func) - (funcall func) - (message-position-on-field (caar args))) - (insert (replace-regexp-in-string - "\r\n" "\n" - (mapconcat #'identity (reverse (cdar args)) ", ") nil t)) - (setq args (cdr args))) - (if subject - (message-goto-body) - (message-goto-subject)))) + (gnus-msg-mail) + (message-mailto-1 url)) (defun gnus-button-embedded-url (address) "Activate ADDRESS with `browse-url'." diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el index e3e81c8bbce..9b08e6a0ef8 100644 --- a/lisp/gnus/gnus-async.el +++ b/lisp/gnus/gnus-async.el @@ -227,6 +227,7 @@ that was fetched." (narrow-to-region mark (point-max)) ;; Put the articles into the agent, if they aren't already. (when (and gnus-agent + gnus-agent-eagerly-store-articles (gnus-agent-group-covered-p group)) (save-restriction (narrow-to-region mark (point-max)) diff --git a/lisp/gnus/gnus-bookmark.el b/lisp/gnus/gnus-bookmark.el index ea4af2df0c4..4f85349d166 100644 --- a/lisp/gnus/gnus-bookmark.el +++ b/lisp/gnus/gnus-bookmark.el @@ -242,7 +242,7 @@ So the cdr of each bookmark is an alist too.") (save-window-excursion ;; Avoid warnings? ;; (message "Saving Gnus bookmarks to file %s..." gnus-bookmark-default-file) - (set-buffer (get-buffer-create " *Gnus bookmarks*")) + (set-buffer (gnus-get-buffer-create " *Gnus bookmarks*")) (erase-buffer) (gnus-bookmark-insert-file-format-version-stamp) (pp gnus-bookmark-alist (current-buffer)) @@ -345,8 +345,7 @@ copy of the alist." (when gnus-bookmark-sort-flag (setq gnus-bookmark-alist (sort (copy-alist gnus-bookmark-alist) - (function - (lambda (x y) (string-lessp (car x) (car y)))))))) + (lambda (x y) (string-lessp (car x) (car y))))))) ;;;###autoload (defun gnus-bookmark-bmenu-list () @@ -357,8 +356,8 @@ deletion, or > if it is flagged for displaying." (interactive) (gnus-bookmark-maybe-load-default-file) (if (called-interactively-p 'any) - (switch-to-buffer (get-buffer-create "*Gnus Bookmark List*")) - (set-buffer (get-buffer-create "*Gnus Bookmark List*"))) + (switch-to-buffer (gnus-get-buffer-create "*Gnus Bookmark List*")) + (set-buffer (gnus-get-buffer-create "*Gnus Bookmark List*"))) (let ((inhibit-read-only t) alist name start end) (erase-buffer) @@ -648,7 +647,7 @@ reposition and try again, else return nil." (details gnus-bookmark-bookmark-details) detail) (save-excursion - (pop-to-buffer (get-buffer-create "*Gnus Bookmark Annotation*") t) + (pop-to-buffer (gnus-get-buffer-create "*Gnus Bookmark Annotation*") t) (erase-buffer) (while details (setq detail (pop details)) diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index 02a8ea723d3..c31d97d41cd 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -93,6 +93,8 @@ it's not cached." (autoload 'nnml-generate-nov-databases-directory "nnml") (autoload 'nnvirtual-find-group-art "nnvirtual") +(autoload 'nnselect-article-group "nnselect") +(autoload 'nnselect-article-number "nnselect") @@ -158,8 +160,12 @@ it's not cached." (file-name-coding-system nnmail-pathname-coding-system)) ;; If this is a virtual group, we find the real group. (when (gnus-virtual-group-p group) - (let ((result (nnvirtual-find-group-art - (gnus-group-real-name group) article))) + (let ((result (if (gnus-nnselect-group-p group) + (with-current-buffer gnus-summary-buffer + (cons (nnselect-article-group article) + (nnselect-article-number article))) + (nnvirtual-find-group-art + (gnus-group-real-name group) article)))) (setq group (car result) number (cdr result)))) (when (and number @@ -186,7 +192,7 @@ it's not cached." (gnus-cache-update-file-total-fetched-for group file)) (setq lines-chars (nnheader-get-lines-and-char)) (nnheader-remove-body) - (setq headers (nnheader-parse-naked-head)) + (setq headers (nnheader-parse-head t)) (setf (mail-header-number headers) number) (setf (mail-header-lines headers) (car lines-chars)) (setf (mail-header-chars headers) (cadr lines-chars)) @@ -232,8 +238,14 @@ it's not cached." (let ((arts gnus-cache-removable-articles) ga) (while arts - (when (setq ga (nnvirtual-find-group-art - (gnus-group-real-name gnus-newsgroup-name) (pop arts))) + (when (setq ga + (if (gnus-nnselect-group-p gnus-newsgroup-name) + (with-current-buffer gnus-summary-buffer + (let ((article (pop arts))) + (cons (nnselect-article-group article) + (nnselect-article-number article)))) + (nnvirtual-find-group-art + (gnus-group-real-name gnus-newsgroup-name) (pop arts)))) (let ((gnus-cache-removable-articles (list (cdr ga))) (gnus-newsgroup-name (car ga))) (gnus-cache-possibly-remove-articles-1))))) @@ -467,8 +479,12 @@ Returns the list of articles removed." (file-name-coding-system nnmail-pathname-coding-system)) ;; If this is a virtual group, we find the real group. (when (gnus-virtual-group-p group) - (let ((result (nnvirtual-find-group-art - (gnus-group-real-name group) article))) + (let ((result (if (gnus-nnselect-group-p group) + (with-current-buffer gnus-summary-buffer + (cons (nnselect-article-group article) + (nnselect-article-number article))) + (nnvirtual-find-group-art + (gnus-group-real-name group) article)))) (setq group (car result) number (cdr result)))) (setq file (gnus-cache-file-name group number)) diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index cecfaef2f4f..3e23e263262 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -223,13 +223,10 @@ easy interactive way to set this from the Server buffer." (t (gnus-message 1 "Unknown type %s; ignoring" type)))))) -(defun gnus-cloud-update-newsrc-data (group elem &optional force-older) - "Update the newsrc data for GROUP from ELEM. -Use old data if FORCE-OLDER is not nil." +(defun gnus-cloud-update-newsrc-data (group elem) + "Update the newsrc data for GROUP from ELEM." (let* ((contents (plist-get elem :contents)) (date (or (plist-get elem :timestamp) "0")) - (now (gnus-cloud-timestamp nil)) - (newer (string-lessp date now)) (group-info (gnus-get-info group))) (if (and contents (stringp (nth 0 contents)) @@ -238,15 +235,13 @@ Use old data if FORCE-OLDER is not nil." (if (equal (format "%S" group-info) (format "%S" contents)) (gnus-message 3 "Skipping cloud update of group %s, the info is the same" group) - (if (and newer (not force-older)) - (gnus-message 3 "Skipping outdated cloud info for group %s, the info is from %s (now is %s)" group date now) - (when (or (not gnus-cloud-interactive) - (gnus-y-or-n-p - (format "%s has older different info in the cloud as of %s, update it here? " - group date)))) - (gnus-message 2 "Installing cloud update of group %s" group) - (gnus-set-info group contents) - (gnus-group-update-group group))) + (when (or (not gnus-cloud-interactive) + (gnus-y-or-n-p + (format "%s has different info in the cloud from %s, update it here? " + group date))) + (gnus-message 2 "Installing cloud update of group %s" group) + (gnus-set-info group contents) + (gnus-group-update-group group))) (gnus-error 1 "Sorry, group %s is not subscribed" group)) (gnus-error 1 "Sorry, could not update newsrc for group %s (invalid data %S)" group elem)))) @@ -285,8 +280,8 @@ Use old data if FORCE-OLDER is not nil." (insert new-contents) (when (file-exists-p file-name) (rename-file file-name (car (find-backup-file-name file-name)))) - (write-region (point-min) (point-max) file-name) - (set-file-times file-name (parse-iso8601-time-string date)))) + (write-region (point-min) (point-max) file-name nil nil nil 'excl) + (set-file-times file-name (parse-iso8601-time-string date) 'nofollow))) (defun gnus-cloud-file-covered-p (file-name) (let ((matched nil)) @@ -380,8 +375,9 @@ When FULL is t, upload everything, not just a difference from the last full." (gnus-cloud-files-to-upload full) (gnus-cloud-collect-full-newsrc))) (group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))) + (setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0))) (insert (format "Subject: (sequence: %s type: %s storage-method: %s)\n" - (or gnus-cloud-sequence "UNKNOWN") + gnus-cloud-sequence (if full :full :partial) gnus-cloud-storage-method)) (insert "From: nobody@gnus.cloud.invalid\n") @@ -390,12 +386,13 @@ When FULL is t, upload everything, not just a difference from the last full." (if (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method t t) (progn - (setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0))) (gnus-cloud-add-timestamps elems) (gnus-message 3 "Uploaded Gnus Cloud data successfully to %s" group) (gnus-group-refresh-group group)) (gnus-error 2 "Failed to upload Gnus Cloud data to %s" group))))) +(defvar gnus-alter-header-function) + (defun gnus-cloud-add-timestamps (elems) (dolist (elem elems) (let* ((file-name (plist-get elem :file-name)) @@ -414,8 +411,9 @@ When FULL is t, upload everything, not just a difference from the last full." (when (gnus-retrieve-headers (gnus-uncompress-range active) group) (with-current-buffer nntp-server-buffer (goto-char (point-min)) - (while (and (not (eobp)) - (setq head (nnheader-parse-head))) + (while (setq head (nnheader-parse-head)) + (when gnus-alter-header-function + (funcall gnus-alter-header-function head)) (push head headers)))) (sort (nreverse headers) (lambda (h1 h2) @@ -459,18 +457,21 @@ instead of `gnus-cloud-sequence'. When UPDATE is t, returns the result of calling `gnus-cloud-update-all'. Otherwise, returns the Gnus Cloud data chunks." (let ((articles nil) + (highest-sequence-seen gnus-cloud-sequence) chunks) (dolist (header (gnus-cloud-available-chunks)) - (when (> (gnus-cloud-chunk-sequence (mail-header-subject header)) - (or sequence-override gnus-cloud-sequence -1)) - - (if (string-match (format "storage-method: %s" gnus-cloud-storage-method) - (mail-header-subject header)) - (push (mail-header-number header) articles) - (gnus-message 1 "Skipping article %s because it didn't match the Gnus Cloud method %s: %s" - (mail-header-number header) - gnus-cloud-storage-method - (mail-header-subject header))))) + (let ((this-sequence (gnus-cloud-chunk-sequence (mail-header-subject header)))) + (when (> this-sequence (or sequence-override gnus-cloud-sequence -1)) + + (if (string-match (format "storage-method: %s" gnus-cloud-storage-method) + (mail-header-subject header)) + (progn + (push (mail-header-number header) articles) + (setq highest-sequence-seen (max highest-sequence-seen this-sequence))) + (gnus-message 1 "Skipping article %s because it didn't match the Gnus Cloud method %s: %s" + (mail-header-number header) + gnus-cloud-storage-method + (mail-header-subject header)))))) (when articles (nnimap-request-articles (nreverse articles) gnus-cloud-group-name) (with-current-buffer nntp-server-buffer @@ -480,7 +481,8 @@ Otherwise, returns the Gnus Cloud data chunks." (push (gnus-cloud-parse-chunk) chunks) (forward-line 1)))) (if update - (mapcar #'gnus-cloud-update-all chunks) + (prog1 (mapcar #'gnus-cloud-update-all chunks) + (setq gnus-cloud-sequence highest-sequence-seen)) chunks))) (defun gnus-cloud-server-p (server) diff --git a/lisp/gnus/gnus-dbus.el b/lisp/gnus/gnus-dbus.el new file mode 100644 index 00000000000..8fbeffba437 --- /dev/null +++ b/lisp/gnus/gnus-dbus.el @@ -0,0 +1,70 @@ +;;; gnus-dbus.el --- DBUS integration for Gnus -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Eric Abrahamsen <eric@ericabrahamsen.net> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library contains some Gnus integration for systems using DBUS. +;; At present it registers a signal to close all Gnus servers before +;; system sleep or hibernation. + +;;; Code: + +(require 'gnus) +(require 'dbus) +(declare-function gnus-close-all-servers "gnus-start") + +(defcustom gnus-dbus-close-on-sleep nil + "When non-nil, close Gnus servers on system sleep." + :group 'gnus-dbus + :type 'boolean) + +(defvar gnus-dbus-sleep-registration-object nil + "Object returned from `dbus-register-signal'. +Used to unregister the signal.") + +(defun gnus-dbus-register-sleep-signal () + "Use `dbus-register-signal' to close servers on sleep." + (when (featurep 'dbusbind) + (setq gnus-dbus-sleep-registration-object + (dbus-register-signal :system + "org.freedesktop.login1" + "/org/freedesktop/login1" + "org.freedesktop.login1.Manager" + "PrepareForSleep" + #'gnus-dbus-sleep-handler)) + (gnus-add-shutdown #'gnus-dbus-unregister-sleep-signal 'gnus))) + +(defun gnus-dbus-sleep-handler (sleep-start) + ;; Sleep-start is t before sleeping. + (when (and sleep-start + (gnus-alive-p)) + (condition-case nil + (gnus-close-all-servers) + (error nil)))) + +(defun gnus-dbus-unregister-sleep-signal () + (condition-case nil + (dbus-unregister-object + gnus-dbus-sleep-registration-object) + (wrong-type-argument nil))) + +(provide 'gnus-dbus) +;;; gnus-dbus.el ends here diff --git a/lisp/gnus/gnus-delay.el b/lisp/gnus/gnus-delay.el index 8dae4ef5c17..63e938e7453 100644 --- a/lisp/gnus/gnus-delay.el +++ b/lisp/gnus/gnus-delay.el @@ -75,7 +75,11 @@ DELAY is a string, giving the length of the time. Possible values are: variable `gnus-delay-default-hour', minute and second are zero. * hh:mm for a specific time. Use 24h format. If it is later than this - time, then the deadline is tomorrow, else today." + time, then the deadline is tomorrow, else today. + +The value of `message-draft-headers' determines which headers are +generated when the article is delayed. Remaining headers are +generated when the article is sent." (interactive (list (read-string "Target date (YYYY-MM-DD), time (hh:mm), or length of delay (units in [mhdwMY]): " diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el index 1b25d247389..3a9bf2a7e8f 100644 --- a/lisp/gnus/gnus-draft.el +++ b/lisp/gnus/gnus-draft.el @@ -248,7 +248,7 @@ If DONT-POP is nil, display the buffer after setting it up." (let ((article narticle)) (message-mail nil nil nil nil (if dont-pop - (lambda (buf) (set-buffer (get-buffer-create buf))))) + (lambda (buf) (set-buffer (gnus-get-buffer-create buf))))) (let ((inhibit-read-only t)) (erase-buffer)) (if (not (gnus-request-restore-buffer article group)) diff --git a/lisp/gnus/gnus-eform.el b/lisp/gnus/gnus-eform.el index 54118aad1e6..1bc1261ee8f 100644 --- a/lisp/gnus/gnus-eform.el +++ b/lisp/gnus/gnus-eform.el @@ -50,13 +50,13 @@ (defvar gnus-edit-form-buffer "*Gnus edit form*") (defvar gnus-edit-form-done-function nil) -(defvar gnus-edit-form-mode-map nil) -(unless gnus-edit-form-mode-map - (setq gnus-edit-form-mode-map (make-sparse-keymap)) - (set-keymap-parent gnus-edit-form-mode-map emacs-lisp-mode-map) - (gnus-define-keys gnus-edit-form-mode-map - "\C-c\C-c" gnus-edit-form-done - "\C-c\C-k" gnus-edit-form-exit)) +(defvar gnus-edit-form-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map emacs-lisp-mode-map) + (gnus-define-keys map + "\C-c\C-c" gnus-edit-form-done + "\C-c\C-k" gnus-edit-form-exit) + map)) (defun gnus-edit-form-make-menu-bar () (unless (boundp 'gnus-edit-form-menu) @@ -67,9 +67,9 @@ ["Exit" gnus-edit-form-exit t])) (gnus-run-hooks 'gnus-edit-form-menu-hook))) -(define-derived-mode gnus-edit-form-mode fundamental-mode "Edit Form" +(define-derived-mode gnus-edit-form-mode lisp-data-mode "Edit Form" "Major mode for editing forms. -It is a slightly enhanced emacs-lisp-mode. +It is a slightly enhanced `lisp-data-mode'. \\{gnus-edit-form-mode-map}" (when (gnus-visual-p 'group-menu 'menu) diff --git a/lisp/gnus/gnus-fun.el b/lisp/gnus/gnus-fun.el index 33cbf4a54a9..3218649761a 100644 --- a/lisp/gnus/gnus-fun.el +++ b/lisp/gnus/gnus-fun.el @@ -40,7 +40,7 @@ "Regexp to match faces in `gnus-x-face-directory' to be omitted." :version "25.1" :group 'gnus-fun - :type '(choice (const nil) string)) + :type '(choice (const nil) regexp)) (defcustom gnus-face-directory (expand-file-name "faces" gnus-directory) "Directory where Face PNG files are stored." @@ -52,7 +52,7 @@ "Regexp to match faces in `gnus-face-directory' to be omitted." :version "25.1" :group 'gnus-fun - :type '(choice (const nil) string)) + :type '(choice (const nil) regexp)) (defcustom gnus-convert-pbm-to-x-face-command "pbmtoxbm %s | compface" "Command for converting a PBM to an X-Face." @@ -205,11 +205,12 @@ different input formats." (defun gnus-convert-face-to-png (face) "Convert FACE (which is base64-encoded) to a PNG. The PNG is returned as a string." - (mm-with-unibyte-buffer - (insert face) - (ignore-errors - (base64-decode-region (point-min) (point-max))) - (buffer-string))) + (let ((face (gnus-base64-repad face nil nil t))) + (mm-with-unibyte-buffer + (insert face) + (ignore-errors + (base64-decode-region (point-min) (point-max))) + (buffer-string)))) ;;;###autoload (defun gnus-convert-png-to-face (file) diff --git a/lisp/gnus/gnus-gravatar.el b/lisp/gnus/gnus-gravatar.el index e2bd4ed860c..9c24de44cd6 100644 --- a/lisp/gnus/gnus-gravatar.el +++ b/lisp/gnus/gnus-gravatar.el @@ -109,14 +109,16 @@ callback for `gravatar-retrieve'." ;; If we're on the " quoting the name, go backward. (when (looking-at-p "[\"<]") (goto-char (1- (point)))) - ;; Do not do anything if there's already a gravatar. This can - ;; happen if the buffer has been regenerated in the mean time, for - ;; example we were fetching someaddress, and then we change to - ;; another mail with the same someaddress. - (unless (get-text-property (point) 'gnus-gravatar) + ;; Do not do anything if there's already a gravatar. + ;; This can happen if the buffer has been regenerated in + ;; the mean time, for example we were fetching + ;; someaddress, and then we change to another mail with + ;; the same someaddress. + (unless (get-text-property (1- (point)) 'gnus-gravatar) (let ((pos (point))) (setq gravatar (append gravatar gnus-gravatar-properties)) - (gnus-put-image gravatar (buffer-substring pos (1+ pos)) category) + (gnus-put-image gravatar (buffer-substring pos (1+ pos)) + category) (put-text-property pos (point) 'gnus-gravatar address) (gnus-add-wash-type category) (gnus-add-image category gravatar))))) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index b89f040b435..73fda66fb6b 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -49,11 +49,11 @@ (autoload 'gnus-agent-total-fetched-for "gnus-agent") (autoload 'gnus-cache-total-fetched-for "gnus-cache") -(autoload 'gnus-group-make-nnir-group "nnir") - (autoload 'gnus-cloud-upload-all-data "gnus-cloud") (autoload 'gnus-cloud-download-all-data "gnus-cloud") +(autoload 'gnus-topic-find-groups "gnus-topic") + (defcustom gnus-no-groups-message "No news is good news" "Message displayed by Gnus when no groups are available." :group 'gnus-start @@ -663,7 +663,8 @@ simple manner." "D" gnus-group-enter-directory "f" gnus-group-make-doc-group "w" gnus-group-make-web-group - "G" gnus-group-make-nnir-group + "G" gnus-group-read-ephemeral-search-group + "g" gnus-group-make-search-group "M" gnus-group-read-ephemeral-group "r" gnus-group-rename-group "R" gnus-group-make-rss-group @@ -909,7 +910,8 @@ simple manner." ["Add the help group" gnus-group-make-help-group t] ["Make a doc group..." gnus-group-make-doc-group t] ["Make a web group..." gnus-group-make-web-group t] - ["Make a search group..." gnus-group-make-nnir-group t] + ["Read a search group..." gnus-group-read-ephemeral-search-group t] + ["Make a search group..." gnus-group-make-search-group t] ["Make a virtual group..." gnus-group-make-empty-virtual t] ["Add a group to a virtual..." gnus-group-add-to-virtual t] ["Make an ephemeral group..." gnus-group-read-ephemeral-group t] @@ -1129,8 +1131,8 @@ The following commands are available: (gnus-update-group-mark-positions) (when gnus-use-undo (gnus-undo-mode 1)) - (when gnus-slave - (gnus-slave-mode))) + (when gnus-child + (gnus-child-mode))) (defun gnus-update-group-mark-positions () (save-excursion @@ -1768,7 +1770,7 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated." (get-text-property (point-at-bol) 'gnus-unread)) (defun gnus-group-new-mail (group) - (if (nnmail-new-mail-p (gnus-group-real-name group)) + (if (nnmail-new-mail-p group) gnus-new-mail-mark ?\s)) @@ -2411,13 +2413,13 @@ the bug number, and browsing the URL must return mbox output." (require 'bug-reference) (let ((def (cond ((thing-at-point-looking-at bug-reference-bug-regexp 500) (match-string 2)) - ((number-at-point))))) + ((and (number-at-point) + (abs (number-at-point))))))) ;; Pass DEF as the value of COLLECTION instead of DEF because: ;; a) null input should not cause DEF to be returned and ;; b) TAB and M-n still work this way. - (or (completing-read-multiple - (format "Bug IDs%s: " (if def (format " (default %s)" def) "")) - (and def (list (format "%s" def)))) + (or (completing-read-multiple (format-prompt "Bug IDs" def) + (and def (list (format "%s" def)))) def))) (defun gnus-read-ephemeral-bug-group (ids mbox-url &optional window-conf) @@ -3165,6 +3167,113 @@ mail messages or news articles in files that have numeric names." (gnus-group-real-name group) (list 'nndir (gnus-group-real-name group) (list 'nndir-directory dir))))) +(autoload 'gnus-group-topic-name "gnus-topic") +(autoload 'gnus-search-make-spec "gnus-search") + +;; Temporary to make group creation easier +(defun gnus-group-make-search-group (no-parse &optional specs) + "Make a group based on a search. +Prompt for a search query and determine the groups to search as +follows: if called from the *Server* buffer search all groups +belonging to the server on the current line; if called from the +*Group* buffer search any marked groups, or the group on the +current line, or all the groups under the current topic. A +prefix arg NO-PARSE means that Gnus should not parse the search +query before passing it to the underlying search engine. A +non-nil SPECS arg must be an alist with `search-query-spec' and +`search-group-spec' keys, and skips all prompting." + (interactive "P") + (let ((name (gnus-read-group "Group name: "))) + (with-current-buffer gnus-group-buffer + (let* ((group-spec + (or + (cdr (assq 'search-group-spec specs)) + (cdr (assq 'nnir-group-spec specs)) + (if (gnus-server-server-name) + (list (list (gnus-server-server-name))) + (seq-group-by + (lambda (elt) (gnus-group-server elt)) + (or gnus-group-marked + (if (gnus-group-group-name) + (list (gnus-group-group-name)) + (mapcar #'caadr + (gnus-topic-find-groups + (gnus-group-topic-name) + nil 'all nil t)))))))) + (query-spec + (or + (cdr (assq 'search-query-spec specs)) + (cdr (assq 'nnir-query-spec specs)) + (gnus-search-make-spec no-parse)))) + ;; If our query came via an old call to nnir, we know not to + ;; parse the query. + (when (assq 'nnir-query-spec specs) + (setf (alist-get 'raw query-spec) t)) + (gnus-group-make-group + name + (list 'nnselect "nnselect") + nil + (list + (cons 'nnselect-specs + (list + (cons 'nnselect-function 'gnus-search-run-query) + (cons 'nnselect-args + (list (cons 'search-query-spec query-spec) + (cons 'search-group-spec group-spec))))) + (cons 'nnselect-artlist nil))))))) + +(define-obsolete-function-alias 'gnus-group-make-nnir-group + 'gnus-group-read-ephemeral-search-group "28.1") + +(defun gnus-group-read-ephemeral-search-group (no-parse &optional specs) + "Read an nnselect group based on a search. +Prompt for a search query and determine the groups to search as +follows: if called from the *Server* buffer search all groups +belonging to the server on the current line; if called from the +*Group* buffer search any marked groups, or the group on the +current line, or all the groups under the current topic. A +prefix arg NO-PARSE means that Gnus should not parse the search +query before passing it to the underlying search engine. A +non-nil SPECS arg must be an alist with `search-query-spec' and +`search-group-spec' keys, and skips all prompting." + (interactive "P") + (let* ((group-spec + (or (cdr (assq 'search-group-spec specs)) + (cdr (assq 'nnir-group-spec specs)) + (if (gnus-server-server-name) + (list (list (gnus-server-server-name))) + (seq-group-by + (lambda (elt) (gnus-group-server elt)) + (or gnus-group-marked + (if (gnus-group-group-name) + (list (gnus-group-group-name)) + (mapcar #'caadr + (gnus-topic-find-groups + (gnus-group-topic-name) + nil 'all nil t)))))))) + (query-spec + (or (cdr (assq 'search-query-spec specs)) + (cdr (assq 'nnir-query-spec specs)) + (gnus-search-make-spec no-parse)))) + ;; If our query came via an old call to nnir, we know not to parse + ;; the query. + (when (assq 'nnir-query-spec specs) + (setf (alist-get 'raw query-spec) t)) + (gnus-group-read-ephemeral-group + (concat "nnselect-" (message-unique-id)) + (list 'nnselect "nnselect") + nil + (cons (current-buffer) gnus-current-window-configuration) + nil nil + (list + (cons 'nnselect-specs + (list + (cons 'nnselect-function 'gnus-search-run-query) + (cons 'nnselect-args + (list (cons 'search-query-spec query-spec) + (cons 'search-group-spec group-spec))))) + (cons 'nnselect-artlist nil))))) + (defun gnus-group-add-to-virtual (n vgroup) "Add the current group to a virtual group." (interactive @@ -3600,7 +3709,7 @@ or nil if no action could be taken." (marks (gnus-info-marks (nth 1 entry))) (unread (gnus-sequence-of-unread-articles group))) ;; Remove entries for this group. - (nnmail-purge-split-history (gnus-group-real-name group)) + (nnmail-purge-split-history group) ;; Do the updating only if the newsgroup isn't killed. (if (not (numberp (car entry))) (gnus-message 1 "Can't catch up %s; non-active group" group) @@ -3697,9 +3806,8 @@ Uses the process/prefix convention." (error "No group on the current line")) (string-to-number (let ((s (read-string - (format "Level (default %s): " - (or (gnus-group-group-level) - gnus-level-default-subscribed))))) + (format-prompt "Level" (or (gnus-group-group-level) + gnus-level-default-subscribed))))) (if (string-match "^\\s-*$" s) (int-to-string (or (gnus-group-group-level) gnus-level-default-subscribed)) @@ -3761,10 +3869,10 @@ group line." (newsrc ;; Toggle subscription flag. (gnus-group-change-level - newsrc (if level level (if (<= (gnus-info-level (nth 1 newsrc)) - gnus-level-subscribed) - (1+ gnus-level-subscribed) - gnus-level-default-subscribed))) + newsrc (or level (if (<= (gnus-info-level (nth 1 newsrc)) + gnus-level-subscribed) + (1+ gnus-level-subscribed) + gnus-level-default-subscribed))) (unless silent (gnus-group-update-group group))) ((and (stringp group) @@ -3773,7 +3881,7 @@ group line." ;; Add new newsgroup. (gnus-group-change-level group - (if level level gnus-level-default-subscribed) + (or level gnus-level-default-subscribed) (or (and (member group gnus-zombie-list) gnus-level-zombie) gnus-level-killed) @@ -4024,9 +4132,9 @@ otherwise all levels below ARG will be scanned too." (gnus-run-hooks 'gnus-get-top-new-news-hook) (gnus-run-hooks 'gnus-get-new-news-hook) - ;; Read any slave files. - (unless gnus-slave - (gnus-master-read-slave-newsrc)) + ;; Read any child files. + (unless gnus-child + (gnus-parent-read-child-newsrc)) (gnus-get-unread-articles (gnus-group-default-level arg t) nil one-level) @@ -4300,8 +4408,7 @@ The hook `gnus-suspend-gnus-hook' is called before actually suspending." ;; Closing all the backends is useful (for instance) when when the ;; IP addresses have changed and you need to reconnect. (dolist (elem gnus-opened-servers) - (gnus-close-server (car elem)) - (setcar (cdr elem) 'closed)) + (gnus-close-server (car elem))) (when group-buf (bury-buffer group-buf) (delete-windows-on group-buf t)))) diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index ee556a32080..389bce85e8b 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -5,18 +5,20 @@ ;; Author: Jan Tatarik <Jan.Tatarik@gmail.com> ;; Keywords: mail, icalendar, org -;; This program is free software; you can redistribute it and/or modify +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -132,11 +134,27 @@ (cl-defmethod gnus-icalendar-event:recurring-interval ((event gnus-icalendar-event)) "Return recurring interval of EVENT." (let ((rrule (gnus-icalendar-event:recur event)) - (default-interval 1)) + (default-interval "1")) + + (if (string-match "INTERVAL=\\([[:digit:]]+\\)" rrule) + (match-string 1 rrule) + default-interval))) - (string-match "INTERVAL=\\([[:digit:]]+\\)" rrule) - (or (match-string 1 rrule) - default-interval))) +(cl-defmethod gnus-icalendar-event:recurring-days ((event gnus-icalendar-event)) + "Return, when available, the week day numbers on which the EVENT recurs." + (let ((rrule (gnus-icalendar-event:recur event)) + (weekday-map '(("SU" . 0) + ("MO" . 1) + ("TU" . 2) + ("WE" . 3) + ("TH" . 4) + ("FR" . 5) + ("SA" . 6)))) + (when (and rrule (string-match "BYDAY=\\([^;]+\\)" rrule)) + (let ((bydays (split-string (match-string 1 rrule) ","))) + (seq-map + (lambda (x) (cdr (assoc x weekday-map))) + (seq-filter (lambda (x) (string-match "^[A-Z]\\{2\\}$" x)) bydays)))))) (cl-defmethod gnus-icalendar-event:start ((event gnus-icalendar-event)) (format-time-string "%Y-%m-%d %H:%M" (gnus-icalendar-event:start-time event))) @@ -162,8 +180,10 @@ (or (member (attendee-name prop) name-or-email) (let ((att-email (attendee-email prop))) (gnus-icalendar-find-if - (lambda (email) - (string-match email att-email)) + (lambda (str-or-fun) + (if (functionp str-or-fun) + (funcall str-or-fun att-email) + (string-match str-or-fun att-email))) name-or-email)))))) (gnus-icalendar-find-if #'attendee-prop-matches-p event-props)))) @@ -244,7 +264,14 @@ (map-property ical-property)) args))))) (mapc #'accumulate-args prop-map) - (apply #'make-instance event-class args)))) + (apply + #'make-instance + event-class + (cl-loop for slot in (eieio-class-slots event-class) + for keyword = (intern + (format ":%s" (eieio-slot-descriptor-name slot))) + when (plist-member args keyword) + append (list keyword (plist-get args keyword))))))) (defun gnus-icalendar-event-from-buffer (buf &optional attendee-name-or-email) "Parse RFC5545 iCalendar in buffer BUF and return an event object. @@ -312,7 +339,8 @@ status will be retrieved from the first matching attendee record." (unless (gnus-icalendar-find-if (lambda (x) (string-match "^ATTENDEE" x)) reply-event-lines) - (error "Could not find an event attendee matching given identity")) + (lwarn 'gnus-icalendar :warning + "Could not find an event attendee matching given identity")) (mapconcat #'identity `("BEGIN:VEVENT" ,@(nreverse reply-event-lines) @@ -400,21 +428,26 @@ Return nil for non-recurring EVENT." (when org-freq (format "+%s%s" (gnus-icalendar-event:recurring-interval event) org-freq))))) -(cl-defmethod gnus-icalendar-event:org-timestamp ((event gnus-icalendar-event)) - "Build `org-mode' timestamp from EVENT start/end dates and recurrence info." - (let* ((start (gnus-icalendar-event:start-time event)) - (end (gnus-icalendar-event:end-time event)) - (start-date (format-time-string "%Y-%m-%d" start)) +(defun gnus-icalendar--find-day (start-date end-date day) + (let ((time-1-day 86400)) + (if (= (decoded-time-weekday (decode-time start-date)) + day) + (list start-date end-date) + (gnus-icalendar--find-day (time-add start-date time-1-day) + (time-add end-date time-1-day) + day)))) + +(defun gnus-icalendar-event--org-timestamp (start end org-repeat) + (let* ((start-date (format-time-string "%Y-%m-%d" start)) (start-time (format-time-string "%H:%M" start)) (start-at-midnight (string= start-time "00:00")) (end-date (format-time-string "%Y-%m-%d" end)) (end-time (format-time-string "%H:%M" end)) (end-at-midnight (string= end-time "00:00")) (start-end-date-diff - (time-to-number-of-days (time-subtract - (org-time-string-to-time end-date) - (org-time-string-to-time start-date)))) - (org-repeat (gnus-icalendar-event:org-repeat event)) + (time-to-number-of-days + (time-subtract (org-time-string-to-time end-date) + (org-time-string-to-time start-date)))) (repeat (if org-repeat (concat " " org-repeat) "")) (time-1-day 86400)) @@ -445,7 +478,31 @@ Return nil for non-recurring EVENT." ;; A .:. - A .:. -> A .:.-.:. ;; A .:. - B .:. ((zerop start-end-date-diff) (format "<%s %s-%s%s>" start-date start-time end-time repeat)) - (t (format "<%s %s>--<%s %s>" start-date start-time end-date end-time))))) + (t (format "<%s %s>--<%s %s>" start-date start-time end-date end-time)))) + ) + +(cl-defmethod gnus-icalendar-event:org-timestamp ((event gnus-icalendar-event)) + "Build `org-mode' timestamp from EVENT start/end dates and recurrence info." + ;; if org-repeat +1d or +1w and byday: generate one timestamp per + ;; byday, starting at start-date. Change +1d to +7d. + (let ((start (gnus-icalendar-event:start-time event)) + (end (gnus-icalendar-event:end-time event)) + (org-repeat (gnus-icalendar-event:org-repeat event)) + (recurring-days (gnus-icalendar-event:recurring-days event))) + (if (and (or (string= org-repeat "+1d") + (string= org-repeat "+1w")) + recurring-days) + (let ((repeat "+1w") + (dates (seq-sort-by + 'car + 'time-less-p + (seq-map (lambda (x) + (gnus-icalendar--find-day start end x)) + recurring-days)))) + (mapconcat (lambda (x) + (gnus-icalendar-event--org-timestamp (car x) (cadr x) + repeat)) dates "\n")) + (gnus-icalendar-event--org-timestamp start end org-repeat)))) (defun gnus-icalendar--format-summary-line (summary &optional location) (if location @@ -715,9 +772,8 @@ These will be used to retrieve the RSVP information from ical events." (lambda (x) (if (listp x) x (list x))) (list user-full-name (regexp-quote user-mail-address) ;; NOTE: these can be lists - gnus-ignored-from-addresses ; already regexp-quoted - (unless (functionp message-alternative-emails) ; String or function. - message-alternative-emails) + gnus-ignored-from-addresses ; String or function. + message-alternative-emails ; String or function. (mapcar #'regexp-quote gnus-icalendar-additional-identities))))) ;; TODO: make the template customizable @@ -756,7 +812,7 @@ These will be used to retrieve the RSVP information from ical events." `(let ((,charset (cdr (assoc 'charset (mm-handle-type ,handle))))) (with-temp-buffer (mm-insert-part ,handle) - (when (string= (downcase ,charset) "utf-8") + (when (and ,charset (string= (downcase ,charset) "utf-8")) (decode-coding-region (point-min) (point-max) 'utf-8)) ,@body)))) @@ -814,7 +870,7 @@ These will be used to retrieve the RSVP information from ical events." (let ((subject (concat (capitalize (symbol-name status)) ": " (gnus-icalendar-event:summary event)))) - (with-current-buffer (get-buffer-create gnus-icalendar-reply-bufname) + (with-current-buffer (gnus-get-buffer-create gnus-icalendar-reply-bufname) (delete-region (point-min) (point-max)) (insert reply) (fold-icalendar-buffer) diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index c304f575d92..b8be766c84f 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -253,7 +253,7 @@ If it is down, start it up (again)." (defun gnus-backend-trace (type form) (when gnus-backend-trace - (with-current-buffer (get-buffer-create "*gnus trace*") + (with-current-buffer (gnus-get-buffer-create "*gnus trace*") (buffer-disable-undo) (goto-char (point-max)) (insert (format-time-string "%H:%M:%S") @@ -351,9 +351,12 @@ If it is down, start it up (again)." "Close the connection to GNUS-COMMAND-METHOD." (when (stringp gnus-command-method) (setq gnus-command-method (gnus-server-to-method gnus-command-method))) - (funcall (gnus-get-function gnus-command-method 'close-server) - (nth 1 gnus-command-method) - (nthcdr 2 gnus-command-method))) + (prog1 + (funcall (gnus-get-function gnus-command-method 'close-server) + (nth 1 gnus-command-method) + (nthcdr 2 gnus-command-method)) + (when-let ((elem (assoc gnus-command-method gnus-opened-servers))) + (setf (nth 1 elem) 'closed)))) (defun gnus-request-list (gnus-command-method) "Request the active file from GNUS-COMMAND-METHOD." @@ -362,6 +365,48 @@ If it is down, start it up (again)." (funcall (gnus-get-function gnus-command-method 'request-list) (nth 1 gnus-command-method))) +(defun gnus-server-get-active (server &optional ignored) + "Return the active list for SERVER. +Groups matching the IGNORED regexp are excluded." + (let ((method (gnus-server-to-method server)) + groups) + (gnus-request-list method) + (with-current-buffer nntp-server-buffer + (let ((cur (current-buffer))) + (goto-char (point-min)) + (unless (or (null ignored) + (string= ignored "")) + (delete-matching-lines ignored)) + (if (eq (car method) 'nntp) + (while (not (eobp)) + (ignore-errors + (push (gnus-group-full-name + (buffer-substring + (point) + (progn + (skip-chars-forward "^ \t") + (point))) + method) + groups)) + (forward-line)) + (while (not (eobp)) + (ignore-errors + (push (if (eq (char-after) ?\") + (gnus-group-full-name (read cur) method) + (let ((p (point)) (name "")) + (skip-chars-forward "^ \t\\\\") + (setq name (buffer-substring p (point))) + (while (eq (char-after) ?\\) + (setq p (1+ (point))) + (forward-char 2) + (skip-chars-forward "^ \t\\\\") + (setq name (concat name (buffer-substring + p (point))))) + (gnus-group-full-name name method))) + groups)) + (forward-line))))) + groups)) + (defun gnus-finish-retrieve-group-infos (gnus-command-method infos data) "Read and update infos from GNUS-COMMAND-METHOD." (when (stringp gnus-command-method) diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el index 5edbaaf201b..a772281d4c3 100644 --- a/lisp/gnus/gnus-kill.el +++ b/lisp/gnus/gnus-kill.el @@ -653,7 +653,7 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score" gnus-options-not-subscribe) ;; Eat all arguments. (setq command-line-args-left nil) - (gnus-slave) + (gnus-child) ;; Apply kills to specified newsgroups in command line arguments. (setq newsrc (cdr gnus-newsrc-alist)) (while (setq info (pop newsrc)) diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index daaea3980b5..465871eafbd 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -393,10 +393,9 @@ only affect the Gcc copy, but not the original message." (gnus-inews-make-draft-meta-information ,gnus-newsgroup-name ',articles))) -(autoload 'nnir-article-number "nnir" nil nil 'macro) -(autoload 'nnir-article-group "nnir" nil nil 'macro) -(autoload 'gnus-nnir-group-p "nnir") - +(autoload 'nnselect-article-number "nnselect" nil nil 'macro) +(autoload 'nnselect-article-group "nnselect" nil nil 'macro) +(autoload 'gnus-nnselect-group-p "nnselect") (defvar gnus-article-reply nil) (defmacro gnus-setup-message (config &rest forms) @@ -404,22 +403,24 @@ only affect the Gcc copy, but not the original message." (winconf-name (make-symbol "gnus-setup-message-winconf-name")) (buffer (make-symbol "gnus-setup-message-buffer")) (article (make-symbol "gnus-setup-message-article")) + (oarticle (make-symbol "gnus-setup-message-oarticle")) (yanked (make-symbol "gnus-setup-yanked-articles")) (group (make-symbol "gnus-setup-message-group"))) `(let ((,winconf (current-window-configuration)) (,winconf-name gnus-current-window-configuration) (,buffer (buffer-name (current-buffer))) - (,article (if (and (gnus-nnir-group-p gnus-newsgroup-name) - gnus-article-reply) - (nnir-article-number (or (car-safe gnus-article-reply) - gnus-article-reply)) - gnus-article-reply)) + (,article (when gnus-article-reply + (or (nnselect-article-number + (or (car-safe gnus-article-reply) + gnus-article-reply)) + gnus-article-reply))) + (,oarticle gnus-article-reply) (,yanked gnus-article-yanked-articles) - (,group (if (and (gnus-nnir-group-p gnus-newsgroup-name) - gnus-article-reply) - (nnir-article-group (or (car-safe gnus-article-reply) - gnus-article-reply)) - gnus-newsgroup-name)) + (,group (when gnus-article-reply + (or (nnselect-article-group + (or (car-safe gnus-article-reply) + gnus-article-reply)) + gnus-newsgroup-name))) (message-header-setup-hook (copy-sequence message-header-setup-hook)) (mbl mml-buffer-list) @@ -460,24 +461,23 @@ only affect the Gcc copy, but not the original message." (unwind-protect (progn ,@forms) - (gnus-inews-add-send-actions ,winconf ,buffer ,article ,config + (gnus-inews-add-send-actions ,winconf ,buffer ,oarticle ,config ,yanked ,winconf-name) (setq gnus-message-buffer (current-buffer)) (set (make-local-variable 'gnus-message-group-art) (cons ,group ,article)) - (set (make-local-variable 'gnus-newsgroup-name) ,group) - ;; Enable highlighting of different citation levels - (when gnus-message-highlight-citation - (gnus-message-citation-mode 1)) - (gnus-run-hooks 'gnus-message-setup-hook) - (if (eq major-mode 'message-mode) - (let ((mbl1 mml-buffer-list)) - (setq mml-buffer-list mbl) ;; Global value - (set (make-local-variable 'mml-buffer-list) mbl1);; Local value - (add-hook 'change-major-mode-hook 'mml-destroy-buffers nil t) - (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)) - (mml-destroy-buffers) - (setq mml-buffer-list mbl))) + ;; Enable highlighting of different citation levels + (when gnus-message-highlight-citation + (gnus-message-citation-mode 1)) + (gnus-run-hooks 'gnus-message-setup-hook) + (if (eq major-mode 'message-mode) + (let ((mbl1 mml-buffer-list)) + (setq mml-buffer-list mbl) ;; Global value + (set (make-local-variable 'mml-buffer-list) mbl1);; Local value + (add-hook 'change-major-mode-hook 'mml-destroy-buffers nil t) + (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)) + (mml-destroy-buffers) + (setq mml-buffer-list mbl))) (message-hide-headers) (gnus-add-buffer) (gnus-configure-windows ,config t) @@ -521,12 +521,10 @@ instead." mail-buf) (unwind-protect (progn - (setq gnus-newsgroup-name "") + (let ((gnus-newsgroup-name "")) (gnus-setup-message 'message (message-mail to subject other-headers continue - nil yank-action send-actions return-action))) - (with-current-buffer buf - (setq gnus-newsgroup-name group-name))) + nil yank-action send-actions return-action))))) (when switch-action (setq mail-buf (current-buffer)) (switch-to-buffer buf) @@ -617,18 +615,15 @@ If ARG is 1, prompt for a group name to find the posting style." (buffer (current-buffer))) (unwind-protect (progn - (setq gnus-newsgroup-name - (if arg - (if (= 1 (prefix-numeric-value arg)) - (gnus-group-completing-read - "Use posting style of group" - nil (gnus-read-active-file-p)) - (gnus-group-group-name)) - "")) - ;; #### see comment in gnus-setup-message -- drv - (gnus-setup-message 'message (message-mail))) - (with-current-buffer buffer - (setq gnus-newsgroup-name group))))) + (let ((gnus-newsgroup-name + (if arg + (if (= 1 (prefix-numeric-value arg)) + (gnus-group-completing-read + "Use posting style of group" + nil (gnus-read-active-file-p)) + (gnus-group-group-name)) + ""))) + (gnus-setup-message 'message (message-mail))))))) (defun gnus-group-news (&optional arg) "Start composing a news. @@ -647,19 +642,16 @@ network. The corresponding back end must have a `request-post' method." (buffer (current-buffer))) (unwind-protect (progn - (setq gnus-newsgroup-name + (let ((gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) (gnus-group-completing-read "Use group" nil (gnus-read-active-file-p)) (gnus-group-group-name)) - "")) - ;; #### see comment in gnus-setup-message -- drv + ""))) (gnus-setup-message 'message - (message-news (gnus-group-real-name gnus-newsgroup-name)))) - (with-current-buffer buffer - (setq gnus-newsgroup-name group))))) + (message-news (gnus-group-real-name gnus-newsgroup-name)))))))) (defun gnus-group-post-news (&optional arg) "Start composing a message (a news by default). @@ -694,18 +686,15 @@ posting style." (buffer (current-buffer))) (unwind-protect (progn - (setq gnus-newsgroup-name + (let ((gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) (gnus-group-completing-read "Use group" nil (gnus-read-active-file-p)) "") - gnus-newsgroup-name)) - ;; #### see comment in gnus-setup-message -- drv - (gnus-setup-message 'message (message-mail))) - (with-current-buffer buffer - (setq gnus-newsgroup-name group))))) + gnus-newsgroup-name))) + (gnus-setup-message 'message (message-mail))))))) (defun gnus-summary-news-other-window (&optional arg) "Start composing a news in another window. @@ -724,24 +713,21 @@ network. The corresponding back end must have a `request-post' method." (buffer (current-buffer))) (unwind-protect (progn - (setq gnus-newsgroup-name + (let ((gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) (gnus-group-completing-read "Use group" nil (gnus-read-active-file-p)) "") - gnus-newsgroup-name)) - ;; #### see comment in gnus-setup-message -- drv + gnus-newsgroup-name))) (gnus-setup-message 'message (progn (message-news (gnus-group-real-name gnus-newsgroup-name)) (set (make-local-variable 'gnus-discouraged-post-methods) (remove (car (gnus-find-method-for-group gnus-newsgroup-name)) - gnus-discouraged-post-methods))))) - (with-current-buffer buffer - (setq gnus-newsgroup-name group))))) + gnus-discouraged-post-methods))))))))) (defun gnus-summary-post-news (&optional arg) "Start composing a message. Post to the current group by default. @@ -823,7 +809,7 @@ active, the entire article will be yanked." (with-current-buffer gnus-article-copy (save-restriction (nnheader-narrow-to-headers) - (nnheader-parse-naked-head))))) + (nnheader-parse-head t))))) (message-yank-original) (message-exchange-point-and-mark) (setq beg (or beg (mark t)))) @@ -1366,8 +1352,10 @@ For the \"inline\" alternatives, also see the variable gcc))) (insert "Gcc: " (mapconcat 'identity gcc ", ") "\n"))))))) -(defun gnus-summary-resend-message (address n) - "Resend the current article to ADDRESS." +(defun gnus-summary-resend-message (address n &optional no-select) + "Resend the current article to ADDRESS. +Uses the process/prefix convention. If NO-SELECT, don't display +the message before resending." (interactive (list (message-read-from-minibuffer "Resend message(s) to: " @@ -1386,6 +1374,7 @@ For the \"inline\" alternatives, also see the variable 'posting-style t)) (user-full-name user-full-name) (user-mail-address user-mail-address) + (group gnus-newsgroup-name) tem) (dolist (style styles) (when (stringp (cadr style)) @@ -1409,11 +1398,18 @@ For the \"inline\" alternatives, also see the variable '(gnus-agent-possibly-do-gcc) '(gnus-inews-do-gcc))))) (dolist (article (gnus-summary-work-articles n)) - (gnus-summary-select-article nil nil nil article) - (with-current-buffer gnus-original-article-buffer - (let ((gnus-gcc-externalize-attachments nil) - (message-inhibit-body-encoding t)) - (message-resend address))) + (if no-select + (with-current-buffer " *nntpd*" + (erase-buffer) + (gnus-request-article article group) + (let ((gnus-gcc-externalize-attachments nil) + (message-inhibit-body-encoding t)) + (message-resend address))) + (gnus-summary-select-article nil nil nil article) + (with-current-buffer gnus-original-article-buffer + (let ((gnus-gcc-externalize-attachments nil) + (message-inhibit-body-encoding t)) + (message-resend address)))) (gnus-summary-mark-article-as-forwarded article)))) ;; From: Matthieu Moy <Matthieu.Moy@imag.fr> @@ -1510,7 +1506,11 @@ If YANK is non-nil, include the original article." (gnus-inews-yank-articles (list (cdr gnus-article-current))))))) (defun gnus-bug (subject) - "Send a bug report to the Emacs maintainers." + "Send a bug report to the Emacs maintainers. + +Already submitted bugs can be found in the Emacs bug tracker: + + https://debbugs.gnu.org/cgi/pkgreport.cgi?package=emacs;max-bugs=100;base-order=1;bug-rev=1" (interactive "sBug Subject: ") (report-emacs-bug subject) (save-excursion @@ -1594,7 +1594,7 @@ this is a reply." (message-remove-header "gcc") (widen) (setq groups (message-unquote-tokens - (message-tokenize-header gcc " ,"))) + (message-tokenize-header gcc " ,\n\t"))) ;; Copy the article over to some group(s). (while (setq group (pop groups)) (setq method (gnus-inews-group-method group) @@ -1989,10 +1989,10 @@ process-mark several articles, they will all be attached." (gnus-summary-iterate n (gnus-summary-select-article) (with-current-buffer destination - ;; Attach at the end of the buffer. - (save-excursion - (goto-char (point-max)) - (message-forward-make-body-mime gnus-original-article-buffer)))) + ;; Attach at the end of the buffer. + (save-excursion + (goto-char (point-max)) + (message-forward-make-body-mime gnus-original-article-buffer)))) (gnus-configure-windows 'message t))) (provide 'gnus-msg) diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index fd2b44f7424..65bcd0e8a36 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -1,4 +1,4 @@ -;;; gnus-registry.el --- article registry for Gnus +;;; gnus-registry.el --- article registry for Gnus -*- lexical-binding: t; -*- ;; Copyright (C) 2002-2020 Free Software Foundation, Inc. @@ -62,10 +62,10 @@ ;; show the marks as single characters (see the :char property in ;; `gnus-registry-marks'): -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-chars) ;; show the marks by name (see `gnus-registry-marks'): -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-names) ;; TODO: @@ -427,6 +427,8 @@ This is not required after changing `gnus-registry-cache-file'." (gnus-message 4 "Removed %d ignored entries from the Gnus registry" (- old-size (registry-size db))))) +(declare-function gnus-nnselect-group-p "nnselect" (group)) +(declare-function nnselect-article-group "nnselect" (article)) ;; article move/copy/spool/delete actions (defun gnus-registry-action (action data-header from &optional to method) (let* ((id (mail-header-id data-header)) @@ -437,7 +439,10 @@ This is not required after changing `gnus-registry-cache-file'." (or (cdr-safe (assq 'To extra)) ""))) (sender (nth 0 (gnus-registry-extract-addresses (mail-header-from data-header)))) - (from (gnus-group-guess-full-name-from-command-method from)) + (from (gnus-group-guess-full-name-from-command-method + (if (gnus-nnselect-group-p from) + (nnselect-article-group (mail-header-number data-header)) + from))) (to (if to (gnus-group-guess-full-name-from-command-method to) nil))) (gnus-message 7 "Gnus registry: article %s %s from %s to %s" id (if method "respooling" "going") from to) @@ -449,19 +454,21 @@ This is not required after changing `gnus-registry-cache-file'." to subject sender recipients))) (defun gnus-registry-spool-action (id group &optional subject sender recipients) - (let ((to (gnus-group-guess-full-name-from-command-method group)) - (recipients (or recipients - (gnus-registry-sort-addresses - (or (message-fetch-field "cc") "") - (or (message-fetch-field "to") "")))) - (subject (or subject (message-fetch-field "subject"))) - (sender (or sender (message-fetch-field "from")))) - (when (and (stringp id) (string-match "\r$" id)) - (setq id (substring id 0 -1))) - (gnus-message 7 "Gnus registry: article %s spooled to %s" - id - to) - (gnus-registry-handle-action id nil to subject sender recipients))) + (save-restriction + (message-narrow-to-headers-or-head) + (let ((to (gnus-group-guess-full-name-from-command-method group)) + (recipients (or recipients + (gnus-registry-sort-addresses + (or (message-fetch-field "cc") "") + (or (message-fetch-field "to") "")))) + (subject (or subject (message-fetch-field "subject"))) + (sender (or sender (message-fetch-field "from")))) + (when (and (stringp id) (string-match "\r$" id)) + (setq id (substring id 0 -1))) + (gnus-message 7 "Gnus registry: article %s spooled to %s" + id + to) + (gnus-registry-handle-action id nil to subject sender recipients)))) (defun gnus-registry-handle-action (id from to subject sender &optional recipients) @@ -485,23 +492,25 @@ This is not required after changing `gnus-registry-cache-file'." (when from (setq entry (cons (delete from (assoc 'group entry)) (assq-delete-all 'group entry)))) - - (dolist (kv `((group ,to) - (sender ,sender) - (recipient ,@recipients) - (subject ,subject))) - (when (cadr kv) - (let ((new (or (assq (car kv) entry) - (list (car kv))))) - (dolist (toadd (cdr kv)) - (unless (member toadd new) - (setq new (append new (list toadd))))) - (setq entry (cons new - (assq-delete-all (car kv) entry)))))) - (gnus-message 10 "Gnus registry: new entry for %s is %S" - id - entry) - (gnus-registry-insert db id entry))) + ;; Only keep the entry if the message is going to a new group, or + ;; it's still in some previous group. + (when (or to (alist-get 'group entry)) + (dolist (kv `((group ,to) + (sender ,sender) + (recipient ,@recipients) + (subject ,subject))) + (when (cadr kv) + (let ((new (or (assq (car kv) entry) + (list (car kv))))) + (dolist (toadd (cdr kv)) + (unless (member toadd new) + (setq new (append new (list toadd))))) + (setq entry (cons new + (assq-delete-all (car kv) entry)))))) + (gnus-message 10 "Gnus registry: new entry for %s is %S" + id + entry) + (gnus-registry-insert db id entry)))) ;; Function for nn{mail|imap}-split-fancy: look up all references in ;; the cache and if a match is found, return that group. @@ -588,7 +597,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." subject (< gnus-registry-minimum-subject-length (length subject))) (let ((groups (apply - 'append + #'append (mapcar (lambda (reference) (gnus-registry-get-id-key reference 'group)) @@ -615,7 +624,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." sender gnus-registry-unfollowed-addresses))) (let ((groups (apply - 'append + #'append (mapcar (lambda (reference) (gnus-registry-get-id-key reference 'group)) @@ -644,7 +653,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (not (gnus-grep-in-list recp gnus-registry-unfollowed-addresses))) - (let ((groups (apply 'append + (let ((groups (apply #'append (mapcar (lambda (reference) (gnus-registry-get-id-key reference 'group)) @@ -663,7 +672,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." ;; filter the found groups and return them ;; the found groups are NOT the full groups (setq found (gnus-registry-post-process-groups - "recipients" (mapconcat 'identity recipients ", ") found))) + "recipients" (mapconcat #'identity recipients ", ") found))) ;; after the (cond) we extract the actual value safely (car-safe found))) @@ -784,14 +793,15 @@ Consults `gnus-registry-unfollowed-groups' and Consults `gnus-registry-ignored-groups' and `nnmail-split-fancy-with-parent-ignore-groups'." (and group - (or (gnus-grep-in-list + (or (gnus-virtual-group-p group) (gnus-grep-in-list group (delq nil (mapcar (lambda (g) (cond ((stringp g) g) ((and (listp g) (nth 1 g)) (nth 0 g)) - (t nil))) gnus-registry-ignored-groups))) + (t nil))) + gnus-registry-ignored-groups))) ;; only use `gnus-parameter-registry-ignore' if ;; `gnus-registry-ignored-groups' is a list of lists ;; (it can be a list of regexes) @@ -871,7 +881,7 @@ Addresses without a name will say \"noname\"." (defun gnus-registry-sort-addresses (&rest addresses) "Return a normalized and sorted list of ADDRESSES." - (sort (mapcan 'gnus-registry-extract-addresses addresses) 'string-lessp)) + (sort (mapcan #'gnus-registry-extract-addresses addresses) 'string-lessp)) (defun gnus-registry-simplify-subject (subject) (if (stringp subject) @@ -961,16 +971,15 @@ Uses `gnus-registry-marks' to find what shortcuts to install." (intern (format function-format variant-name))) (shortcut (format "%c" (if remove (upcase data) data)))) (defalias function-name - ;; If it weren't for the function's docstring, we could - ;; use a closure, with lexical-let :-( - `(lambda (&rest articles) - ,(format - "%s the %s mark over process-marked ARTICLES." - (upcase-initials variant-name) - mark) - (interactive - (gnus-summary-work-articles current-prefix-arg)) - (gnus-registry--set/remove-mark ',mark ',remove articles))) + (lambda (&rest articles) + (:documentation + (format + "%s the %s mark over process-marked ARTICLES." + (upcase-initials variant-name) + mark)) + (interactive + (gnus-summary-work-articles current-prefix-arg)) + (gnus-registry--set/remove-mark mark remove articles))) (push function-name keys-plist) (push shortcut keys-plist) (push (vector (format "%s %s" @@ -990,14 +999,11 @@ Uses `gnus-registry-marks' to find what shortcuts to install." nil (cons "Registry Marks" gnus-registry-misc-menus)))))) -(make-obsolete 'gnus-registry-user-format-function-M - 'gnus-registry-article-marks-to-chars "24.1") ? - -(defalias 'gnus-registry-user-format-function-M - 'gnus-registry-article-marks-to-chars) +(define-obsolete-function-alias 'gnus-registry-user-format-function-M + #'gnus-registry-article-marks-to-chars "24.1") ;; use like this: -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-chars) (defun gnus-registry-article-marks-to-chars (headers) "Show the marks for an article by the :char property." (if gnus-registry-enabled @@ -1013,20 +1019,20 @@ Uses `gnus-registry-marks' to find what shortcuts to install." "")) ;; use like this: -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-names) (defun gnus-registry-article-marks-to-names (headers) "Show the marks for an article by name." (if gnus-registry-enabled (let* ((id (mail-header-message-id headers)) (marks (when id (gnus-registry-get-id-key id 'mark)))) - (mapconcat (lambda (mark) (symbol-name mark)) marks ",")) + (mapconcat #'symbol-name marks ",")) "")) (defun gnus-registry-read-mark () "Read a mark name from the user with completion." (let ((mark (gnus-completing-read "Label" - (mapcar 'symbol-name (mapcar 'car gnus-registry-marks)) + (mapcar #'symbol-name (mapcar #'car gnus-registry-marks)) nil nil nil (symbol-name gnus-registry-default-mark)))) (when (stringp mark) @@ -1050,7 +1056,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install." show-message) "Apply or remove MARK across a list of ARTICLES." (let ((article-id-list - (mapcar 'gnus-registry-fetch-message-id-fast articles))) + (mapcar #'gnus-registry-fetch-message-id-fast articles))) (dolist (id article-id-list) (let* ((marks (delq mark (gnus-registry-get-id-key id 'mark))) (marks (if remove marks (cons mark marks)))) @@ -1173,34 +1179,34 @@ only the last one's marks are returned." (gnus-registry-install-shortcuts) (if (gnus-alive-p) (gnus-registry-load) - (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load))) + (add-hook 'gnus-read-newsrc-el-hook #'gnus-registry-load))) (defun gnus-registry-install-hooks () "Install the registry hooks." (setq gnus-registry-enabled t) - (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action) - (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) - (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) - (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action) + (add-hook 'gnus-summary-article-move-hook #'gnus-registry-action) + (add-hook 'gnus-summary-article-delete-hook #'gnus-registry-action) + (add-hook 'gnus-summary-article-expire-hook #'gnus-registry-action) + (add-hook 'nnmail-spool-hook #'gnus-registry-spool-action) - (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save) + (add-hook 'gnus-save-newsrc-hook #'gnus-registry-save) - (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) + (add-hook 'gnus-summary-prepare-hook #'gnus-registry-register-message-ids)) (defun gnus-registry-unload-hook () "Uninstall the registry hooks." - (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action) - (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) - (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) - (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action) + (remove-hook 'gnus-summary-article-move-hook #'gnus-registry-action) + (remove-hook 'gnus-summary-article-delete-hook #'gnus-registry-action) + (remove-hook 'gnus-summary-article-expire-hook #'gnus-registry-action) + (remove-hook 'nnmail-spool-hook #'gnus-registry-spool-action) - (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save) - (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load) + (remove-hook 'gnus-save-newsrc-hook #'gnus-registry-save) + (remove-hook 'gnus-read-newsrc-el-hook #'gnus-registry-load) - (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids) + (remove-hook 'gnus-summary-prepare-hook #'gnus-registry-register-message-ids) (setq gnus-registry-enabled nil)) -(add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook) +(add-hook 'gnus-registry-unload-hook #'gnus-registry-unload-hook) (defun gnus-registry-install-p () "Return non-nil if the registry is enabled (and maybe enable it first). @@ -1217,7 +1223,7 @@ is `ask', ask the user; or if `gnus-registry-install' is non-nil, enable it." (gnus-registry-initialize))) gnus-registry-enabled) -;; largely based on nnir-warp-to-article +;; largely based on nnselect-warp-to-article (defun gnus-try-warping-via-registry () "Try to warp via the registry. This will be done via the current article's source group based on @@ -1234,14 +1240,14 @@ data stored in the registry." (seen-groups (list (gnus-group-group-name)))) (catch 'found - (dolist (group (mapcar 'gnus-simplify-group-name groups)) + (dolist (group (mapcar #'gnus-simplify-group-name groups)) ;; skip over any groups we really don't want to warp to. (unless (or (member group seen-groups) (gnus-ephemeral-group-p group) ;; any ephemeral group (memq (car (gnus-find-method-for-group group)) ;; Specific methods; this list may need to expand. - '(nnir))) + '(nnselect))) ;; remember that we've seen this group already (push group seen-groups) @@ -1270,7 +1276,7 @@ EXTRA is a list of symbols. Valid symbols are those contained in the docs of `gnus-registry-track-extra'. This command is useful when you stop tracking some extra data and now want to purge it from your existing entries." - (interactive (list (mapcar 'intern + (interactive (list (mapcar #'intern (completing-read-multiple "Extra data: " '("subject" "sender" "recipient"))))) diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index 46b70eaf275..2e3abe7832d 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -25,8 +25,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (require 'gnus) (require 'gnus-sum) (require 'gnus-art) @@ -35,6 +33,7 @@ (require 'message) (require 'score-mode) (require 'gmm-utils) +(require 'cl-lib) (defcustom gnus-global-score-files nil "List of global score files and directories. @@ -497,6 +496,7 @@ of the last successful match.") ("head" -1 gnus-score-body) ("body" -1 gnus-score-body) ("all" -1 gnus-score-body) + (score-fn -1 nil) ("followup" 2 gnus-score-followup) ("thread" 5 gnus-score-thread))) @@ -862,6 +862,18 @@ If optional argument `EXTRA' is non-nil, it's a non-standard overview header." (setq match (string-to-number match))) (set-text-properties 0 (length match) nil match)) + ;; Modify match and type for article age scoring. + (if (string= "date" (nth 0 (assoc header gnus-header-index))) + (let ((age (string-to-number match))) + (if (or (< age 0) + (string= "0" match)) + (user-error "Article age must be a positive number")) + (setq match age + type (cond ((eq type 'after) + '<) + ((eq type 'before) + '>))))) + (unless (eq date 'now) ;; Add the score entry to the score file. (when (= score gnus-score-interactive-default-score) @@ -1163,14 +1175,19 @@ If FORMAT, also format the current score file." (when format (gnus-score-pretty-print)) (when (consp rule) ;; the rule exists - (setq rule (mapconcat #'(lambda (obj) - (regexp-quote (format "%S" obj))) - rule - sep)) + (setq rule (if (symbolp (car rule)) + (format "(%S)" (car rule)) + (mapconcat #'(lambda (obj) + (regexp-quote (format "%S" obj))) + rule + sep))) (goto-char (point-min)) - (re-search-forward rule nil t) - ;; make it easy to use `kill-sexp': - (goto-char (1- (match-beginning 0))))))) + (let ((move (if (string-match "(.*)" rule) + 0 + -1))) + (re-search-forward rule nil t) + ;; make it easy to use `kill-sexp': + (goto-char (+ move (match-beginning 0)))))))) (defun gnus-score-load-file (file) ;; Load score file FILE. Returns a list a retrieved score-alists. @@ -1220,6 +1237,7 @@ If FORMAT, also format the current score file." (let ((mark (car (gnus-score-get 'mark alist))) (expunge (car (gnus-score-get 'expunge alist))) (mark-and-expunge (car (gnus-score-get 'mark-and-expunge alist))) + (score-fn (car (gnus-score-get 'score-fn alist))) (files (gnus-score-get 'files alist)) (exclude-files (gnus-score-get 'exclude-files alist)) (orphan (car (gnus-score-get 'orphan alist))) @@ -1370,9 +1388,12 @@ If FORMAT, also format the current score file." (setq err (cond - ((if (member (downcase type) '("lines" "chars")) - (not (numberp (car s))) - (not (stringp (car s)))) + ((cond ((member (downcase type) '("lines" "chars")) + (not (numberp (car s)))) + ((string= (downcase type) "date") + (not (or (numberp (car s)) + (stringp (car s))))) + (t (not (stringp (car s))))) (format "Invalid match %s in %s" (car s) file)) ((and (cadr s) (not (integerp (cadr s)))) (format "Non-integer score %s in %s" (cadr s) file)) @@ -1552,10 +1573,14 @@ If FORMAT, also format the current score file." (gnus-message 7 "Scoring on headers or body skipped.") nil) + ;; Run score-fn + (if (eq header 'score-fn) + (setq new (gnus-score-func scores trace)) ;; Call the scoring function for this type of "header". (setq new (funcall (nth 2 entry) scores header - now expire trace))) + now expire trace)))) (push new news)))) + (when (gnus-buffer-live-p gnus-summary-buffer) (let ((scored gnus-newsgroup-scored)) (with-current-buffer gnus-summary-buffer @@ -1621,6 +1646,30 @@ score in `gnus-newsgroup-scored' by SCORE." (not (string= id ""))) (gnus-score-lower-thread thread score))))) +(defun gnus-score-func (scores &optional trace) + (dolist (alist scores) + (let ((articles gnus-scores-articles) + (entries (assoc 'score-fn alist))) + (dolist (score-fn (cdr entries)) + (let ((score-fn (car score-fn)) + article-alist score fn-score) + (dolist (art articles) + (setq article-alist + (cl-pairlis + '(number subject from date id + refs chars lines xref extra) + (car art)) + score (cdr art)) + (when (integerp (setq fn-score (funcall score-fn + article-alist score))) + (setcdr art (+ score fn-score))) + (setq score (cdr art)) + (when (and trace + (integerp fn-score)) + (push (cons (car-safe (rassq alist gnus-score-cache)) + (list score-fn fn-score)) + gnus-score-trace)))))))) + (defun gnus-score-integer (scores header now expire &optional trace) (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) entries alist) @@ -1690,9 +1739,21 @@ score in `gnus-newsgroup-scored' by SCORE." ((eq type 'after) (setq match-func 'string< match (gnus-date-iso8601 (nth 0 kill)))) + ((eq type '<) + (setq type 'after + match-func 'string< + match (gnus-time-iso8601 + (time-subtract (current-time) + (* 86400 (nth 0 kill)))))) ((eq type 'before) (setq match-func 'gnus-string> match (gnus-date-iso8601 (nth 0 kill)))) + ((eq type '>) + (setq type 'before + match-func 'gnus-string> + match (gnus-time-iso8601 + (time-subtract (current-time) + (* 86400 (nth 0 kill)))))) ((eq type 'at) (setq match-func 'string= match (gnus-date-iso8601 (nth 0 kill)))) diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el new file mode 100644 index 00000000000..498da200dab --- /dev/null +++ b/lisp/gnus/gnus-search.el @@ -0,0 +1,2158 @@ +;;; gnus-search.el --- Search facilities for Gnus -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Eric Abrahamsen <eric@ericabrahamsen.net> + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file defines a generalized search language, and search engines +;; that interface with various search programs. It is responsible for +;; parsing the user's search input, sending that query to the search +;; engines, and collecting results. Results are in the form of a +;; vector of vectors, each vector representing a found article. The +;; nnselect backend interprets that value to create a group containing +;; the search results. + +;; This file was formerly known as nnir. Later, the backend parts of +;; nnir became nnselect, and only the search functionality was left +;; here. + +;; See the Gnus manual for details of the search language. Tests are +;; in tests/gnus-search-test.el. + +;; The search parsing routines are responsible for accepting the +;; user's search query as a string and parsing it into a sexp +;; structure. The function `gnus-search-parse-query' is the entry +;; point for that. Once the query is in sexp form, it is passed to +;; the search engines themselves, which are responsible for +;; transforming the query into a form that the external program can +;; understand, and then filtering the search results into a format +;; that nnselect can understand. + +;; The general flow is: + +;; 1. The user calls one of `gnus-group-make-search-group' or +;; `gnus-group-make-permanent-search-group' (or a few other entry +;; points). These functions prompt for a search query, and collect +;; the groups to search, then create an nnselect group, setting an +;; 'nnselect-specs group parameter where 'nnselect-function is +;; `gnus-search-run-query', and 'nnselect-args is the search query and +;; groups to search. + +;; 2. `gnus-search-run-query' is called with 'nnselect-args. It looks +;; at the groups to search, categorizes them by server, and for each +;; server finds the search engine to use. It calls each engine's +;; `gnus-search-run-search' method with the query and groups passed as +;; arguments, and the results are collected and handed off to the +;; nnselect group. + +;; For information on writing new search engines, see the Gnus manual. + +;; TODO: Rewrite the query parser using syntax tables and +;; `parse-partial-sexp'. + +;; TODO: Refactor IMAP search so we can move code that uses nnimap-* +;; functions out into nnimap.el. + +;; TODO: Is there anything we can do about sorting results? + +;; TODO: Provide for returning a result count. This would probably +;; need a completely separate top-level command, since we wouldn't be +;; creating a group at all. + +;;; Code: + +(require 'gnus-group) +(require 'gnus-sum) +(require 'message) +(require 'gnus-util) +(require 'eieio) +(eval-when-compile (require 'cl-lib)) +(autoload 'eieio-build-class-alist "eieio-opt") +(autoload 'nnmaildir-base-name-to-article-number "nnmaildir") + +(defvar gnus-inhibit-demon) +(defvar gnus-english-month-names) + +;;; Internal Variables: + +;; When Gnus servers are implemented as objects or structs, give them +;; a `search-engine' slot and get rid of this variable. +(defvar gnus-search-engine-instance-alist nil + "Mapping between servers and instantiated search engines.") + +(defvar gnus-search-history () + "Internal history of Gnus searches.") + +(defun gnus-search-shutdown () + (setq gnus-search-engine-instance-alist nil)) + +(gnus-add-shutdown #'gnus-search-shutdown 'gnus) + +(define-error 'gnus-search-parse-error "Gnus search parsing error") + +;;; User Customizable Variables: + +(defgroup gnus-search nil + "Search groups in Gnus with assorted search engines." + :group 'gnus) + +(defcustom gnus-search-use-parsed-queries nil + "When t, use Gnus' generalized search language. +The generalized search language is a search language that can be +used across all search engines that Gnus supports. See the Gnus +manual for details. + +If this option is set to nil, search queries will be passed +directly to the search engines without being parsed or +transformed." + :version "28.1" + :type 'boolean + :group 'gnus-search) + +(define-obsolete-variable-alias 'nnir-ignored-newsgroups + 'gnus-search-ignored-newsgroups "28.1") + +(defcustom gnus-search-ignored-newsgroups "" + "A regexp to match newsgroups in the active file that should + be skipped when searching." + :version "24.1" + :type 'regexp + :group 'gnus-search) + +(make-obsolete-variable + 'nnir-imap-default-search-key + "specify imap search keys, or use parsed queries." "28.1") + +;; Engine-specific configuration options. + +(defcustom gnus-search-swish++-config-file + (expand-file-name "~/Mail/swish++.conf") + "Location of Swish++ configuration file. +This variable can also be set per-server." + :type 'file + :group 'gnus-search) + +(defcustom gnus-search-swish++-program "search" + "Name of swish++ search executable. +This variable can also be set per-server." + :type 'string + :group 'gnus-search) + +(defcustom gnus-search-swish++-switches '() + "A list of strings, to be given as additional arguments to swish++. +Note that this should be a list. I.e., do NOT use the following: + (setq gnus-search-swish++-switches \"-i -w\") ; wrong +Instead, use this: + (setq gnus-search-swish++-switches \\='(\"-i\" \"-w\")) + +This variable can also be set per-server." + :type '(repeat string) + :group 'gnus-search) + +(defcustom gnus-search-swish++-remove-prefix (concat (getenv "HOME") "/Mail/") + "The prefix to remove from each file name returned by swish++ +in order to get a group name (albeit with / instead of .). This is a +regular expression. + +This variable can also be set per-server." + :type 'regexp + :group 'gnus-search) + +(defcustom gnus-search-swish++-raw-queries-p nil + "If t, all Swish++ engines will only accept raw search query + strings." + :type 'boolean + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-swish-e-config-file + (expand-file-name "~/Mail/swish-e.conf") + "Configuration file for swish-e. +This variable can also be set per-server." + :type 'file + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-swish-e-program "search" + "Name of swish-e search executable. +This variable can also be set per-server." + :type 'string + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-swish-e-switches '() + "A list of strings, to be given as additional arguments to swish-e. +Note that this should be a list. I.e., do NOT use the following: + (setq gnus-search-swish-e-switches \"-i -w\") ; wrong +Instead, use this: + (setq gnus-search-swish-e-switches \\='(\"-i\" \"-w\")) + +This variable can also be set per-server." + :type '(repeat string) + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-swish-e-remove-prefix (concat (getenv "HOME") "/Mail/") + "The prefix to remove from each file name returned by swish-e +in order to get a group name (albeit with / instead of .). This is a +regular expression. + +This variable can also be set per-server." + :type 'regexp + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-swish-e-index-files '() + "A list of index files to use with this Swish-e instance. +This variable can also be set per-server." + :type '(repeat file) + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-swish-e-raw-queries-p nil + "If t, all Swish-e engines will only accept raw search query + strings." + :type 'boolean + :version "28.1" + :group 'gnus-search) + +;; Namazu engine, see <URL:http://www.namazu.org/> + +(defcustom gnus-search-namazu-program "namazu" + "Name of Namazu search executable. +This variable can also be set per-server." + :type 'string + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-namazu-index-directory (expand-file-name "~/Mail/namazu/") + "Index directory for Namazu. +This variable can also be set per-server." + :type 'directory + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-namazu-switches '() + "A list of strings, to be given as additional arguments to namazu. +The switches `-q', `-a', and `-s' are always used, very few other switches +make any sense in this context. + +Note that this should be a list. I.e., do NOT use the following: + (setq gnus-search-namazu-switches \"-i -w\") ; wrong +Instead, use this: + (setq gnus-search-namazu-switches \\='(\"-i\" \"-w\")) + +This variable can also be set per-server." + :type '(repeat string) + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-namazu-remove-prefix (concat (getenv "HOME") "/Mail/") + "The prefix to remove from each file name returned by Namazu +in order to get a group name (albeit with / instead of .). + +For example, suppose that Namazu returns file names such as +\"/home/john/Mail/mail/misc/42\". For this example, use the following +setting: (setq gnus-search-namazu-remove-prefix \"/home/john/Mail/\") +Note the trailing slash. Removing this prefix gives \"mail/misc/42\". +Gnus knows to remove the \"/42\" and to replace \"/\" with \".\" to +arrive at the correct group name, \"mail.misc\". + +This variable can also be set per-server." + :type 'directory + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-namazu-raw-queries-p nil + "If t, all Namazu engines will only accept raw search query + strings." + :type 'boolean + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-notmuch-program "notmuch" + "Name of notmuch search executable. +This variable can also be set per-server." + :type '(string) + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-notmuch-config-file + (expand-file-name "~/.notmuch-config") + "Configuration file for notmuch. +This variable can also be set per-server." + :type 'file + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-notmuch-switches '() + "A list of strings, to be given as additional arguments to notmuch. +Note that this should be a list. I.e., do NOT use the following: + (setq gnus-search-notmuch-switches \"-i -w\") ; wrong +Instead, use this: + (setq gnus-search-notmuch-switches \\='(\"-i\" \"-w\")) + +This variable can also be set per-server." + :type '(repeat string) + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-notmuch-remove-prefix (concat (getenv "HOME") "/Mail/") + "The prefix to remove from each file name returned by notmuch +in order to get a group name (albeit with / instead of .). This is a +regular expression. + +This variable can also be set per-server." + :type 'regexp + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-notmuch-raw-queries-p nil + "If t, all Notmuch engines will only accept raw search query + strings." + :type 'boolean + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-imap-raw-queries-p nil + "If t, all IMAP engines will only accept raw search query + strings." + :version "28.1" + :type 'boolean + :group 'gnus-search) + +(defcustom gnus-search-mairix-program "mairix" + "Name of mairix search executable. +This variable can also be set per-server." + :version "28.1" + :type 'string + :group 'gnus-search) + +(defcustom gnus-search-mairix-config-file + (expand-file-name "~/.mairixrc") + "Configuration file for mairix. +This variable can also be set per-server." + :version "28.1" + :type 'file + :group 'gnus-search) + +(defcustom gnus-search-mairix-switches '() + "A list of strings, to be given as additional arguments to mairix. +Note that this should be a list. I.e., do NOT use the following: + (setq gnus-search-mairix-switches \"-i -w\") ; wrong +Instead, use this: + (setq gnu-search-mairix-switches \\='(\"-i\" \"-w\")) + +This variable can also be set per-server." + :version "28.1" + :type '(repeat string) + :group 'gnus-search) + +(defcustom gnus-search-mairix-remove-prefix (concat (getenv "HOME") "/Mail/") + "The prefix to remove from each file name returned by mairix +in order to get a group name (albeit with / instead of .). This is a +regular expression. + +This variable can also be set per-server." + :version "28.1" + :type 'regexp + :group 'gnus-search) + +(defcustom gnus-search-mairix-raw-queries-p nil + "If t, all Mairix engines will only accept raw search query + strings." + :version "28.1" + :type 'boolean + :group 'gnus-search) + +;; Options for search language parsing. + +(defcustom gnus-search-expandable-keys + '("from" "subject" "to" "cc" "bcc" "body" "recipient" "date" + "mark" "before" "after" "larger" "smaller" "attachment" "text" + "since" "thread" "sender" "address" "tag" "size" "grep" "limit" + "raw" "message-id" "id") + "A list of strings representing expandable search keys. +\"Expandable\" simply means the key can be abbreviated while +typing in search queries, ie \"subject\" could be entered as +\"subj\" or even \"su\", though \"s\" is ambigous between +\"subject\" and \"since\". + +Ambiguous abbreviations will raise an error." + :group 'gnus-search + :version "28.1" + :type '(repeat string)) + +(defcustom gnus-search-date-keys + '("date" "before" "after" "on" "senton" "sentbefore" "sentsince" "since") + "A list of keywords whose value should be parsed as a date. +See the docstring of `gnus-search-parse-query' for information on +date parsing." + :group 'gnus-search + :version "26.1" + :type '(repeat string)) + +(defcustom gnus-search-contact-tables '() + "A list of completion tables used to search for messages from contacts. +Each list element should be a table or collection suitable to be +returned by `completion-at-point-functions'. That usually means +a list of strings, a hash table, or an alist." + :group 'gnus-search + :version "28.1" + :type '(repeat sexp)) + +;;; Search language + +;; This "language" was generalized from the original IMAP search query +;; parsing routine. + +(defun gnus-search-parse-query (string) + "Turn STRING into an s-expression based query. +The resulting query structure is passed to the various search +backends, each of which adapts it as needed. + +The search \"language\" is essentially a series of key:value +expressions. Key is most often a mail header, but there are +other keys. Value is a string, quoted if it contains spaces. +Key and value are separated by a colon, no space. Expressions +are implictly ANDed; the \"or\" keyword can be used to +OR. \"not\" will negate the following expression, or keys can be +prefixed with a \"-\". The \"near\" operator will work for +engines that understand it; other engines will convert it to +\"or\". Parenthetical groups work as expected. + +A key that matches the name of a mail header will search that +header. + +Search keys can be expanded with TAB during entry, or left +abbreviated so long as they remain unambiguous, ie \"f\" will +search the \"from\" header. \"s\" will raise an error. + +Other keys: + +\"address\" will search all sender and recipient headers. + +\"recipient\" will search \"To\", \"Cc\", and \"Bcc\". + +\"before\" will search messages sent before the specified +date (date specifications to come later). Date is exclusive. + +\"after\" (or its synonym \"since\") will search messages sent +after the specified date. Date is inclusive. + +\"mark\" will search messages that have some sort of mark. +Likely values include \"flag\", \"seen\", \"read\", \"replied\". +It's also possible to use Gnus' internal marks, ie \"mark:R\" +will be interpreted as mark:read. + +\"tag\" will search tags -- right now that's translated to +\"keyword\" in IMAP, and left as \"tag\" for notmuch. At some +point this should also be used to search marks in the Gnus +registry. + +Other keys can be specified, provided that the search backends +know how to interpret them. + +External contact-management packages can push completion tables +onto the list variable `gnus-search-contact-tables', to provide +auto-completion of contact names and addresses for keys like +\"from\" and \"to\". + +Date values (any key in `gnus-search-date-keys') can be provided +in any format that `parse-time-string' can parse (note that this +can produce weird results). Dates with missing bits will be +interpreted as the most recent occurance thereof (ie \"march 03\" +is the most recent March 3rd). Lastly, relative specifications +such as 1d (one day ago) are understood. This also accepts w, m, +and y. m is assumed to be 30 days. + +This function will accept pretty much anything as input. Its +only job is to parse the query into a sexp, and pass that on -- +it is the job of the search backends to make sense of the +structured query. Malformed, unusable or invalid queries will +typically be silently ignored." + (with-temp-buffer + ;; Set up the parsing environment. + (insert string) + (goto-char (point-min)) + ;; Now, collect the output terms and return them. + (let (out) + (while (not (gnus-search-query-end-of-input)) + (push (gnus-search-query-next-expr) out)) + (reverse out)))) + +(defun gnus-search-query-next-expr (&optional count halt) + "Return the next expression from the current buffer." + (let ((term (gnus-search-query-next-term count)) + (next (gnus-search-query-peek-symbol))) + ;; Deal with top-level expressions. And, or, not, near... What + ;; else? Notmuch also provides xor and adj. It also provides a + ;; "nearness" parameter for near and adj. + (cond + ;; Handle 'expr or expr' + ((and (eq next 'or) + (null halt)) + (list 'or term (gnus-search-query-next-expr 2))) + ;; Handle 'near operator. + ((eq next 'near) + (let ((near-next (gnus-search-query-next-expr 2))) + (if (and (stringp term) + (stringp near-next)) + (list 'near term near-next) + (signal 'gnus-search-parse-error + (list "\"Near\" keyword must appear between two plain strings."))))) + ;; Anything else + (t term)))) + +(defun gnus-search-query-next-term (&optional count) + "Return the next TERM from the current buffer." + (let ((term (gnus-search-query-next-symbol count))) + ;; What sort of term is this? + (cond + ;; negated term + ((eq term 'not) (list 'not (gnus-search-query-next-expr nil 'halt))) + ;; generic term + (t term)))) + +(defun gnus-search-query-peek-symbol () + "Return the next symbol from the current buffer, but don't consume it." + (save-excursion + (gnus-search-query-next-symbol))) + +(defun gnus-search-query-next-symbol (&optional count) + "Return the next symbol from the current buffer, or nil if we are +at the end of the buffer. If supplied COUNT skips some symbols before +returning the one at the supplied position." + (when (and (numberp count) (> count 1)) + (gnus-search-query-next-symbol (1- count))) + (let ((case-fold-search t)) + ;; end of input stream? + (unless (gnus-search-query-end-of-input) + ;; No, return the next symbol from the stream. + (cond + ;; Negated expression -- return it and advance one char. + ((looking-at "-") (forward-char 1) 'not) + ;; List expression -- we parse the content and return this as a list. + ((looking-at "(") + (gnus-search-parse-query (gnus-search-query-return-string ")" t))) + ;; Keyword input -- return a symbol version. + ((looking-at "\\band\\b") (forward-char 3) 'and) + ((looking-at "\\bor\\b") (forward-char 2) 'or) + ((looking-at "\\bnot\\b") (forward-char 3) 'not) + ((looking-at "\\bnear\\b") (forward-char 4) 'near) + ;; Plain string, no keyword + ((looking-at "[\"/]?\\b[^:]+\\([[:blank:]]\\|\\'\\)") + (gnus-search-query-return-string + (when (looking-at-p "[\"/]") t))) + ;; Assume a K:V expression. + (t (let ((key (gnus-search-query-expand-key + (buffer-substring + (point) + (progn + (re-search-forward ":" (point-at-eol) t) + (1- (point)))))) + (value (gnus-search-query-return-string + (when (looking-at-p "[\"/]") t)))) + (gnus-search-query-parse-kv key value))))))) + +(defun gnus-search-query-parse-kv (key value) + "Handle KEY and VALUE, parsing and expanding as necessary. +This may result in (key value) being turned into a larger query +structure. + +In the simplest case, they are simply consed together. String +KEY is converted to a symbol." + (let (return) + (cond + ((member key gnus-search-date-keys) + (when (string= "after" key) + (setq key "since")) + (setq value (gnus-search-query-parse-date value))) + ((equal key "mark") + (setq value (gnus-search-query-parse-mark value))) + ((string= "message-id" key) + (setq key "id"))) + (or return + (cons (intern key) value)))) + +(defun gnus-search-query-parse-date (value &optional rel-date) + "Interpret VALUE as a date specification. +See the docstring of `gnus-search-parse-query' for details. + +The result is a list of (dd mm yyyy); individual elements can be +nil. + +If VALUE is a relative time, interpret it as relative to +REL-DATE, or (current-time) if REL-DATE is nil." + ;; Time parsing doesn't seem to work with slashes. + (let ((value (replace-regexp-in-string "/" "-" value)) + (now (append '(0 0 0) + (seq-subseq (decode-time (or rel-date + (current-time))) + 3)))) + ;; Check for relative time parsing. + (if (string-match "\\([[:digit:]]+\\)\\([dwmy]\\)" value) + (seq-subseq + (decode-time + (time-subtract + (apply #'encode-time now) + (days-to-time + (* (string-to-number (match-string 1 value)) + (cdr (assoc (match-string 2 value) + '(("d" . 1) + ("w" . 7) + ("m" . 30) + ("y" . 365)))))))) + 3 6) + ;; Otherwise check the value of `parse-time-string'. + + ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ) + (let ((d-time (parse-time-string value))) + ;; Did parsing produce anything at all? + (if (seq-some #'integerp (seq-subseq d-time 3 7)) + (seq-subseq + ;; If DOW is given, handle that specially. + (if (and (seq-elt d-time 6) (null (seq-elt d-time 3))) + (decode-time + (time-subtract (apply #'encode-time now) + (days-to-time + (+ (if (> (seq-elt d-time 6) + (seq-elt now 6)) + 7 0) + (- (seq-elt now 6) (seq-elt d-time 6)))))) + d-time) + 3 6) + ;; `parse-time-string' failed to produce anything, just + ;; return the string. + value))))) + +(defun gnus-search-query-parse-mark (mark) + "Possibly transform MARK. +If MARK is a single character, assume it is one of the +gnus-*-mark marks, and return an appropriate string." + (if (= 1 (length mark)) + (let ((m (aref mark 0))) + ;; Neither pcase nor cl-case will work here. + (cond + ((eql m gnus-ticked-mark) "flag") + ((eql m gnus-read-mark) "read") + ((eql m gnus-replied-mark) "replied") + ((eql m gnus-recent-mark) "recent") + (t mark))) + mark)) + +(defun gnus-search-query-expand-key (key) + (cond ((test-completion key gnus-search-expandable-keys) + ;; We're done! + key) + ;; There is more than one possible completion. + ((consp (cdr (completion-all-completions + key gnus-search-expandable-keys #'stringp 0))) + (signal 'gnus-search-parse-error + (list (format "Ambiguous keyword: %s" key)))) + ;; Return KEY, either completed or untouched. + ((car-safe (completion-try-completion + key gnus-search-expandable-keys + #'stringp 0))))) + +(defun gnus-search-query-return-string (&optional delimited trim) + "Return a string from the current buffer. +If DELIMITED is non-nil, assume the next character is a delimiter +character, and return everything between point and the next +occurance of the delimiter, including the delimiters themselves. +If TRIM is non-nil, do not return the delimiters. Otherwise, +return one word." + ;; This function cannot handle nested delimiters, as it's not a + ;; proper parser. Ie, you cannot parse "to:bob or (from:bob or + ;; (cc:bob or bcc:bob))". + (let ((start (point)) + (delimiter (if (stringp delimited) + delimited + (when delimited + (char-to-string (char-after))))) + end) + (if delimiter + (progn + (when trim + ;; Skip past first delimiter if we're trimming. + (forward-char 1)) + (while (not end) + (unless (search-forward delimiter nil t (unless trim 2)) + (signal 'gnus-search-parse-error + (list (format "Unmatched delimited input with %s in query" delimiter)))) + (let ((here (point))) + (unless (equal (buffer-substring (- here 2) (- here 1)) "\\") + (setq end (if trim (1- (point)) (point)) + start (if trim (1+ start) start)))))) + (setq end (progn (re-search-forward "\\([[:blank:]]+\\|$\\)" (point-max) t) + (match-beginning 0)))) + (buffer-substring-no-properties start end))) + +(defun gnus-search-query-end-of-input () + "Are we at the end of input?" + (skip-chars-forward "[:blank:]") + (looking-at "$")) + +;;; Search engines + +;; Search engines are implemented as classes. This is good for two +;; things: encapsulating things like indexes and search prefixes, and +;; transforming search queries. + +(defclass gnus-search-engine () + ((raw-queries-p + :initarg :raw-queries-p + :initform nil + :type boolean + :custom boolean + :documentation + "When t, searches through this engine will never be parsed or + transformed, and must be entered \"raw\".")) + :abstract t + :documentation "Abstract base class for Gnus search engines.") + +(defclass gnus-search-grep () + ((grep-program + :initarg :grep-program + :initform "grep" + :type string + :documentation "Grep executable to use for second-pass grep + searches.") + (grep-options + :initarg :grep-options + :initform nil + :type list + :documentation "Additional options, in the form of a list, + passed to the second-pass grep search, when present.")) + :abstract t + :documentation "An abstract mixin class that can be added to + local-filesystem search engines, providing an additional grep: + search key. After the base engine returns a list of search + results (as local filenames), an external grep process is used + to further filter the results.") + +(cl-defgeneric gnus-search-grep-search (engine artlist criteria) + "Run a secondary grep search over a list of preliminary results. + +ARTLIST is a list of (filename score) pairs, produced by one of +the other search engines. CRITERIA is a grep-specific search +key. This method uses an external grep program to further filter +the files in ARTLIST by that search key.") + +(cl-defmethod gnus-search-grep-search ((engine gnus-search-grep) + artlist criteria) + (with-slots (grep-program grep-options) engine + (if (executable-find grep-program) + ;; Don't catch errors -- allow them to propagate. + (let ((matched-files + (apply + #'process-lines + grep-program + `("-l" ,@grep-options + "-e" ,(shell-quote-argument criteria) + ,@(mapcar #'car artlist))))) + (seq-filter (lambda (a) (member (car a) matched-files)) + artlist)) + (nnheader-report 'search "invalid grep program: %s" grep-program)))) + +(defclass gnus-search-process () + ((proc-buffer + :initarg :proc-buffer + :type buffer + :documentation "A temporary buffer this engine uses for its + search process, and for munging its search results.")) + :abstract t + :documentation + "A mixin class for engines that do their searching in a single + process launched for this purpose, which returns at the end of + the search. Subclass instances are safe to be run in + threads.") + +(cl-defmethod shared-initialize ((engine gnus-search-process) + slots) + (setq slots (plist-put slots :proc-buffer + (generate-new-buffer " *gnus-search-"))) + (cl-call-next-method engine slots)) + +(defclass gnus-search-imap (gnus-search-engine) + ((literal-plus + :initarg :literal-plus + :initform nil + :type boolean + :documentation + "Can this search engine handle literal+ searches? This slot + is set automatically by the imap server, and cannot be + set manually. Only the LITERAL+ capability is handled.") + (multisearch + :initarg :multisearch + :initform nil + :type boolean + :documentation + "Can this search engine handle the MULTISEARCH capability? + This slot is set automatically by the imap server, and cannot + be set manually. Currently unimplemented.") + (fuzzy + :initarg :fuzzy + :initform nil + :type boolean + :documentation + "Can this search engine handle the FUZZY search capability? + This slot is set automatically by the imap server, and cannot + be set manually. Currently only partially implemented.") + (raw-queries-p + :initform (symbol-value 'gnus-search-imap-raw-queries-p))) + :documentation + "The base IMAP search engine, using an IMAP server's search capabilites. +This backend may be subclassed to handle particular IMAP servers' +quirks.") + +(defclass gnus-search-find-grep (gnus-search-engine + gnus-search-process + gnus-search-grep) + nil) + +;;; The "indexed" search engine. + +;; These are engines that use an external program, with indexes kept +;; on disk, to search messages usually kept in some local directory. +;; They have several slots in common, for instance program name or +;; configuration file. Many of the subclasses also allow +;; distinguishing multiple databases or indexes. These slots can be +;; set using a global default, or on a per-server basis. + +(defclass gnus-search-indexed (gnus-search-engine + gnus-search-process + gnus-search-grep) + ((program + :initarg :program + :type string + :documentation + "The executable used for indexing and searching.") + (config-file + :init-arg :config-file + :type string + :custom file + :documentation "Location of the config file, if any.") + (remove-prefix + :initarg :remove-prefix + :initform (concat (getenv "HOME") "/Mail/") + :type string + :documentation + "The path to the directory where the indexed mails are + kept. This path is removed from the search results.") + (switches + :initarg :switches + :type list + :documentation + "Additional switches passed to the search engine command-line + program.")) + :abstract t + :allow-nil-initform t + :documentation "A base search engine class that assumes a local search index + accessed by a command line program.") + +(defclass gnus-search-swish-e (gnus-search-indexed) + ((index-files + :init-arg :index-files + :initform (symbol-value 'gnus-search-swish-e-index-files) + :type list) + (program + :initform (symbol-value 'gnus-search-swish-e-program)) + (remove-prefix + :initform (symbol-value 'gnus-search-swish-e-remove-prefix)) + (switches + :initform (symbol-value 'gnus-search-swish-e-switches)) + (raw-queries-p + :initform (symbol-value 'gnus-search-swish-e-raw-queries-p)))) + +(defclass gnus-search-swish++ (gnus-search-indexed) + ((program + :initform (symbol-value 'gnus-search-swish++-program)) + (remove-prefix + :initform (symbol-value 'gnus-search-swish++-remove-prefix)) + (switches + :initform (symbol-value 'gnus-search-swish++-switches)) + (config-file + :initform (symbol-value 'gnus-search-swish++-config-file)) + (raw-queries-p + :initform (symbol-value 'gnus-search-swish++-raw-queries-p)))) + +(defclass gnus-search-mairix (gnus-search-indexed) + ((program + :initform (symbol-value 'gnus-search-mairix-program)) + (remove-prefix + :initform (symbol-value 'gnus-search-mairix-remove-prefix)) + (switches + :initform (symbol-value 'gnus-search-mairix-switches)) + (config-file + :initform (symbol-value 'gnus-search-mairix-config-file)) + (raw-queries-p + :initform (symbol-value 'gnus-search-mairix-raw-queries-p)))) + +(defclass gnus-search-namazu (gnus-search-indexed) + ((index-directory + :initarg :index-directory + :type string + :custom directory) + (program + :initform (symbol-value 'gnus-search-namazu-program)) + (remove-prefix + :initform (symbol-value 'gnus-search-namazu-remove-prefix)) + (switches + :initform (symbol-value 'gnus-search-namazu-switches)) + (raw-queries-p + :initform (symbol-value 'gnus-search-namazu-raw-queries-p)))) + +(defclass gnus-search-notmuch (gnus-search-indexed) + ((program + :initform (symbol-value 'gnus-search-notmuch-program)) + (remove-prefix + :initform (symbol-value 'gnus-search-notmuch-remove-prefix)) + (switches + :initform (symbol-value 'gnus-search-notmuch-switches)) + (config-file + :initform (symbol-value 'gnus-search-notmuch-config-file)) + (raw-queries-p + :initform (symbol-value 'gnus-search-notmuch-raw-queries-p)))) + +(define-obsolete-variable-alias 'nnir-method-default-engines + 'gnus-search-default-engines "28.1") + +(defcustom gnus-search-default-engines '((nnimap . gnus-search-imap)) + "Alist of default search engines keyed by server method." + :version "26.1" + :group 'gnus-search + :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)) + (choice + ,@(mapcar + (lambda (el) (list 'const (intern (car el)))) + (eieio-build-class-alist 'gnus-search-engine t)))))) + +;;; Transforming and running search queries. + +(cl-defgeneric gnus-search-run-search (engine server query groups) + "Run QUERY in GROUPS against SERVER, using search ENGINE. +Should return results as a vector of vectors.") + +(cl-defgeneric gnus-search-transform (engine expression) + "Transform sexp EXPRESSION into a string search query usable by ENGINE. +Responsible for handling and, or, and parenthetical expressions.") + +(cl-defgeneric gnus-search-transform-expression (engine expression) + "Transform a basic EXPRESSION into a string usable by ENGINE.") + +(cl-defgeneric gnus-search-make-query-string (engine query-spec) + "Extract the actual query string to use from QUERY-SPEC.") + +;; Methods that are likely to be the same for all engines. + +(cl-defmethod gnus-search-make-query-string ((engine gnus-search-engine) + query-spec) + (let ((parsed-query (alist-get 'parsed-query query-spec)) + (raw-query (alist-get 'query query-spec))) + (if (and gnus-search-use-parsed-queries + (null (alist-get 'raw query-spec)) + (null (slot-value engine 'raw-queries-p)) + parsed-query) + (gnus-search-transform engine parsed-query) + (if (listp raw-query) + ;; Some callers are sending this in as (query "query"), not + ;; as a cons cell? + (car raw-query) + raw-query)))) + +(defsubst gnus-search-single-p (query) + "Return t if QUERY is a search for a single message." + (let ((q (alist-get 'parsed-query query))) + (and (= (length q ) 1) + (consp (car-safe q)) + (eq (caar q) 'id)))) + +(cl-defmethod gnus-search-transform ((engine gnus-search-engine) + (query list)) + (let (clauses) + (mapc + (lambda (item) + (when-let ((expr (gnus-search-transform-expression engine item))) + (push expr clauses))) + query) + (mapconcat #'identity (reverse clauses) " "))) + +;; Most search engines just pass through plain strings. +(cl-defmethod gnus-search-transform-expression ((_ gnus-search-engine) + (expr string)) + expr) + +;; Most search engines use implicit ANDs. +(cl-defmethod gnus-search-transform-expression ((_ gnus-search-engine) + (_expr (eql and))) + nil) + +;; Most search engines use explicit infixed ORs. +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-engine) + (expr (head or))) + (let ((left (gnus-search-transform-expression engine (nth 1 expr))) + (right (gnus-search-transform-expression engine (nth 2 expr)))) + ;; Unhandled keywords return a nil; don't create an "or" expression + ;; unless both sub-expressions are non-nil. + (if (and left right) + (format "%s or %s" left right) + (or left right)))) + +;; Most search engines just use the string "not" +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-engine) + (expr (head not))) + (let ((next (gnus-search-transform-expression engine (cadr expr)))) + (when next + (format "not %s" next)))) + +;;; Search Engine Interfaces: + +(autoload 'nnimap-change-group "nnimap") +(declare-function nnimap-buffer "nnimap" ()) +(declare-function nnimap-command "nnimap" (&rest args)) + +;; imap interface +(cl-defmethod gnus-search-run-search ((engine gnus-search-imap) + srv query groups) + (save-excursion + (let ((server (cadr (gnus-server-to-method srv))) + (gnus-inhibit-demon t) + ;; We're using the message id to look for a single message. + (single-search (gnus-search-single-p query)) + (grouplist (or groups (gnus-search-get-active srv))) + q-string artlist group) + (message "Opening server %s" server) + ;; We should only be doing this once, in + ;; `nnimap-open-connection', but it's too frustrating to try to + ;; get to the server from the process buffer. + (with-current-buffer (nnimap-buffer) + (setf (slot-value engine 'literal-plus) + (when (nnimap-capability "LITERAL+") t)) + ;; MULTISEARCH not yet implemented. + (setf (slot-value engine 'multisearch) + (when (nnimap-capability "MULTISEARCH") t)) + ;; FUZZY only partially supported: the command is sent to the + ;; server (and presumably acted upon), but we don't yet + ;; request a RELEVANCY score as part of the response. + (setf (slot-value engine 'fuzzy) + (when (nnimap-capability "SEARCH=FUZZY") t))) + + (setq q-string + (gnus-search-make-query-string engine query)) + + ;; If it's a thread query, make sure that all message-id + ;; searches are also references searches. + (when (alist-get 'thread query) + (setq q-string + (replace-regexp-in-string + "HEADER Message-Id \\([^ )]+\\)" + "(OR HEADER Message-Id \\1 HEADER References \\1)" + q-string))) + + (while (and (setq group (pop grouplist)) + (or (null single-search) (null artlist))) + (when (nnimap-change-group + (gnus-group-short-name group) server) + (with-current-buffer (nnimap-buffer) + (message "Searching %s..." group) + (let ((result + (gnus-search-imap-search-command engine q-string))) + (when (car result) + (setq artlist + (vconcat + (mapcar + (lambda (artnum) + (let ((artn (string-to-number artnum))) + (when (> artn 0) + (vector group artn 100)))) + (cdr (assoc "SEARCH" (cdr result)))) + artlist)))) + (message "Searching %s...done" group)))) + (nreverse artlist)))) + +(cl-defmethod gnus-search-imap-search-command ((engine gnus-search-imap) + (query string)) + "Create the IMAP search command for QUERY. +Currenly takes into account support for the LITERAL+ capability. +Other capabilities could be tested here." + (with-slots (literal-plus) engine + (when literal-plus + (setq query (split-string query "\n"))) + (cond + ((consp query) + ;; We're not really streaming, just need to prevent + ;; `nnimap-send-command' from waiting for a response. + (let* ((nnimap-streaming t) + (call + (nnimap-send-command + "UID SEARCH CHARSET UTF-8 %s" + (pop query)))) + (dolist (l query) + (process-send-string (get-buffer-process (current-buffer)) l) + (process-send-string (get-buffer-process (current-buffer)) + (if (nnimap-newlinep nnimap-object) + "\n" + "\r\n"))) + (nnimap-get-response call))) + (t (nnimap-command "UID SEARCH %s" query))))) + +;; TODO: Don't exclude booleans and date keys, just check for them +;; before checking for general keywords. +(defvar gnus-search-imap-search-keys + '(body cc bcc from header keyword larger smaller subject text to uid x-gm-raw) + "Known IMAP search keys, excluding booleans and date keys.") + +(cl-defmethod gnus-search-transform ((_ gnus-search-imap) + (_query null)) + "ALL") + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap) + (expr string)) + (unless (string-match-p "\\`/.+/\\'" expr) + ;; Also need to check for fuzzy here. Or better, do some + ;; refactoring of this stuff. + (format "TEXT %s" + (gnus-search-imap-handle-string engine expr)))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap) + (expr (head or))) + (let ((left (gnus-search-transform-expression engine (nth 1 expr))) + (right (gnus-search-transform-expression engine (nth 2 expr)))) + (if (and left right) + (format "(OR %s %s)" + left (format (if (eq 'or (car-safe (nth 2 expr))) + "(%s)" "%s") + right)) + (or left right)))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap) + (expr (head near))) + "Imap searches interpret \"near\" as \"or\"." + (setcar expr 'or) + (gnus-search-transform-expression engine expr)) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap) + (expr (head not))) + "Transform IMAP NOT. +If the term to be negated is a flag, then use the appropriate UN* +boolean instead." + (if (eql (caadr expr) 'mark) + (if (string= (cdadr expr) "new") + "OLD" + (format "UN%s" (gnus-search-imap-handle-flag (cdadr expr)))) + (format "NOT %s" + (gnus-search-transform-expression engine (cadr expr))))) + +(cl-defmethod gnus-search-transform-expression ((_ gnus-search-imap) + (expr (head mark))) + (gnus-search-imap-handle-flag (cdr expr))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap) + (expr list)) + "Handle a search keyword for IMAP. +All IMAP search keywords that take a value are supported +directly. Keywords that are boolean are supported through other +means (usually the \"mark\" keyword)." + (let ((fuzzy-supported (slot-value engine 'fuzzy)) + (fuzzy "")) + (cl-case (car expr) + (date (setcar expr 'on)) + (tag (setcar expr 'keyword)) + (sender (setcar expr 'from)) + (attachment (setcar expr 'body))) + ;; Allow sizes specified as KB or MB. + (let ((case-fold-search t) + unit) + (when (and (memq (car expr) '(larger smaller)) + (string-match "\\(kb?\\|mb?\\)\\'" (cdr expr))) + (setq unit (match-string 1 (cdr expr))) + (setcdr expr + (number-to-string + (* (string-to-number + (string-replace unit "" (cdr expr))) + (if (string-prefix-p "k" unit) + 1024 + 1048576)))))) + (cond + ((consp (car expr)) + (format "(%s)" (gnus-search-transform engine expr))) + ((eq (car expr) 'recipient) + (gnus-search-transform + engine (gnus-search-parse-query + (format + "to:%s or cc:%s or bcc:%s" + (cdr expr) (cdr expr) (cdr expr))))) + ((eq (car expr) 'address) + (gnus-search-transform + engine (gnus-search-parse-query + (format + "from:%s or to:%s or cc:%s or bcc:%s" + (cdr expr) (cdr expr) (cdr expr) (cdr expr))))) + ((memq (car expr) '(before since on sentbefore senton sentsince)) + ;; Ignore dates given as strings. + (when (listp (cdr expr)) + (format "%s %s" + (upcase (symbol-name (car expr))) + (gnus-search-imap-handle-date engine (cdr expr))))) + ((stringp (cdr expr)) + ;; If the search term starts or ends with "*", remove the + ;; asterisk. If the engine supports FUZZY, then additionally make + ;; the search fuzzy. + (when (string-match "\\`\\*\\|\\*\\'" (cdr expr)) + (setcdr expr (replace-regexp-in-string + "\\`\\*\\|\\*\\'" "" (cdr expr))) + (when fuzzy-supported + (setq fuzzy "FUZZY "))) + ;; If the search term is a regexp, drop the expression altogether. + (unless (string-match-p "\\`/.+/\\'" (cdr expr)) + (cond + ((memq (car expr) gnus-search-imap-search-keys) + (format "%s%s %s" + fuzzy + (upcase (symbol-name (car expr))) + (gnus-search-imap-handle-string engine (cdr expr)))) + ((eq (car expr) 'id) + (format "HEADER Message-ID \"%s\"" (cdr expr))) + ;; Treat what can't be handled as a HEADER search. Probably a bad + ;; idea. + (t (format "%sHEADER %s %s" + fuzzy + (car expr) + (gnus-search-imap-handle-string engine (cdr expr)))))))))) + +(cl-defmethod gnus-search-imap-handle-date ((_engine gnus-search-imap) + (date list)) + "Turn DATE into a date string recognizable by IMAP. +While other search engines can interpret partially-qualified +dates such as a plain \"January\", IMAP requires an absolute +date. + +DATE is a list of (dd mm yyyy), any element of which could be +nil. Massage those numbers into the most recent past occurrence +of whichever date elements are present." + (let ((now (decode-time (current-time)))) + ;; Set nil values to 1, current-month, current-year, or else 1, 1, + ;; current-year, depending on what we think the user meant. + (unless (seq-elt date 1) + (setf (seq-elt date 1) + (if (seq-elt date 0) + (seq-elt now 4) + 1))) + (unless (seq-elt date 0) + (setf (seq-elt date 0) 1)) + (unless (seq-elt date 2) + (setf (seq-elt date 2) + (seq-elt now 5))) + ;; Fiddle with the date until it's in the past. There + ;; must be a way to combine all these steps. + (unless (< (seq-elt date 2) + (seq-elt now 5)) + (when (< (seq-elt now 3) + (seq-elt date 0)) + (cl-decf (seq-elt date 1))) + (cond ((zerop (seq-elt date 1)) + (setf (seq-elt date 1) 1) + (cl-decf (seq-elt date 2))) + ((< (seq-elt now 4) + (seq-elt date 1)) + (cl-decf (seq-elt date 2)))))) + (format-time-string "%e-%b-%Y" (apply #'encode-time + (append '(0 0 0) + date)))) + +(cl-defmethod gnus-search-imap-handle-string ((engine gnus-search-imap) + (str string)) + (with-slots (literal-plus) engine + (if (multibyte-string-p str) + ;; If LITERAL+ is available, use it and encode string as + ;; UTF-8. + (if literal-plus + (format "{%d+}\n%s" + (string-bytes str) + (encode-coding-string str 'utf-8)) + ;; Otherwise, if the user hasn't already quoted the string, + ;; quote it for them. + (if (string-prefix-p "\"" str) + str + (format "\"%s\"" str))) + str))) + +(defun gnus-search-imap-handle-flag (flag) + "Make sure string FLAG is something IMAP will recognize." + ;; What else? What about the KEYWORD search key? + (setq flag + (pcase flag + ("flag" "flagged") + ("read" "seen") + (_ flag))) + (if (member flag '("seen" "answered" "deleted" "draft" "flagged")) + (upcase flag) + "")) + +;;; Methods for the indexed search engines. + +;; First, some common methods. + +(cl-defgeneric gnus-search-indexed-parse-output (engine server &optional groups) + "Parse the results of ENGINE's query against SERVER in GROUPS. +Locally-indexed search engines return results as a list of +filenames, sometimes with additional information. Returns a list +of viable results, in the form of a list of [group article score] +vectors.") + +(cl-defgeneric gnus-search-indexed-extract (engine) + "Extract a single article result from the current buffer. +Returns a list of two values: a file name, and a relevancy score. +Advances point to the beginning of the next result.") + +(cl-defmethod gnus-search-run-search ((engine gnus-search-indexed) + server query groups) + "Run QUERY against SERVER using ENGINE. +This method is common to all indexed search engines. + +Returns a list of [group article score] vectors." + + (save-excursion + (let* ((qstring (gnus-search-make-query-string engine query)) + (program (slot-value engine 'program)) + (buffer (slot-value engine 'proc-buffer)) + (cp-list (gnus-search-indexed-search-command + engine qstring query groups)) + proc exitstatus) + (set-buffer buffer) + (erase-buffer) + + (if groups + (message "Doing %s query on %s..." program groups) + (message "Doing %s query..." program)) + (setq proc (apply #'start-process (format "search-%s" server) + buffer program cp-list)) + (while (process-live-p proc) + (accept-process-output proc)) + (setq exitstatus (process-exit-status proc)) + (if (zerop exitstatus) + ;; The search results have been put into the current buffer; + ;; `parse-output' finds them there and returns the article + ;; list. + (gnus-search-indexed-parse-output engine server query groups) + (nnheader-report 'search "%s error: %s" program exitstatus) + ;; Failure reason is in this buffer, show it if the user + ;; wants it. + (when (> gnus-verbose 6) + (display-buffer buffer)) + nil)))) + +(cl-defmethod gnus-search-indexed-parse-output ((engine gnus-search-indexed) + server query &optional groups) + (let ((prefix (slot-value engine 'remove-prefix)) + (group-regexp (when groups + (regexp-opt + (mapcar + (lambda (x) (gnus-group-real-name x)) + groups)))) + artlist vectors article group) + (goto-char (point-min)) + (while (not (eobp)) + (pcase-let ((`(,f-name ,score) (gnus-search-indexed-extract engine))) + (when (and (file-readable-p f-name) + (null (file-directory-p f-name)) + (or (null groups) + (and (gnus-search-single-p query) + (alist-get 'thread query)) + (string-match-p group-regexp f-name))) + (push (list f-name score) artlist)))) + ;; Are we running an additional grep query? + (when-let ((grep-reg (alist-get 'grep query))) + (setq artlist (gnus-search-grep-search engine artlist grep-reg))) + ;; Turn (file-name score) into [group article score]. + (pcase-dolist (`(,f-name ,score) artlist) + (setq article (file-name-nondirectory f-name)) + ;; Remove prefix. + (when (and prefix + (file-name-absolute-p prefix) + (string-match (concat "^" + (file-name-as-directory prefix)) + f-name)) + (setq group (replace-match "" t t (file-name-directory f-name)))) + ;; Break the directory name down until it's something that + ;; (probably) can be used as a group name. + (setq group + (replace-regexp-in-string + "[/\\]" "." + (replace-regexp-in-string + "/?\\(cur\\|new\\|tmp\\)?/\\'" "" + (replace-regexp-in-string + "^[./\\]" "" + group nil t) + nil t) + nil t)) + + (push (vector (gnus-group-full-name group server) + (if (string-match-p "\\`[[:digit:]]+\\'" article) + (string-to-number article) + (nnmaildir-base-name-to-article-number + (substring article 0 (string-match ":" article)) + group nil)) + (if (numberp score) + score + (string-to-number score))) + vectors)) + vectors)) + +(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-indexed)) + "Base implementation treats the whole line as a filename, and +fudges a relevancy score of 100." + (prog1 + (list (buffer-substring-no-properties (line-beginning-position) + (line-end-position)) + 100) + (forward-line 1))) + +;; Swish++ + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-swish++) + (expr (head near))) + (format "%s near %s" + (gnus-search-transform-expression engine (nth 1 expr)) + (gnus-search-transform-expression engine (nth 2 expr)))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-swish++) + (expr list)) + (cond + ((listp (car expr)) + (format "(%s)" (gnus-search-transform engine expr))) + ;; Untested and likely wrong. + ((and (stringp (cdr expr)) + (string-prefix-p "(" (cdr expr))) + (format "%s = %s" (car expr) (gnus-search-transform + engine + (gnus-search-parse-query (cdr expr))))) + (t (format "%s = %s" (car expr) (cdr expr))))) + +(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-swish++) + (qstring string) + _query &optional _groups) + (with-slots (config-file switches) engine + `("--config-file" ,config-file + ,@switches + ,qstring + ))) + +(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-swish++)) + (when (re-search-forward + "\\(^[0-9]+\\) \\([^ ]+\\) [0-9]+ \\(.*\\)$" nil t) + (list (match-string 2) + (match-string 1)))) + +;; Swish-e + +;; I didn't do the query transformation for Swish-e, because the +;; program seems no longer to exist. + +(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-swish-e) + (qstring string) + _query &optional _groups) + (with-slots (index-files switches) engine + `("-f" ,@index-files + ,@switches + "-w" + ,qstring + ))) + +(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-swish-e)) + (when (re-search-forward + "\\(^[0-9]+\\) \\([^ ]+\\) \"\\([^\"]+\\)\" [0-9]+$" nil t) + (list (match-string 3) + (match-string 1)))) + +;; Namazu interface + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-namazu) + (expr list)) + (cond + ((listp (car expr)) + (format "(%s)" (gnus-search-transform engine expr))) + ((eql (car expr) 'body) + (cadr expr)) + ;; I have no idea which fields namazu can handle. Just do these + ;; for now. + ((memq (car expr) '(subject from to)) + (format "+%s:%s" (car expr) (cdr expr))) + ((eql (car expr) 'address) + (gnus-search-transform engine `((or (from . ,(cdr expr)) + (to . ,(cdr expr)))))) + ((eq (car expr) 'id) + (format "+message-id:%s" (cdr expr))) + (t (ignore-errors (cl-call-next-method))))) + +;; I can't tell if this is actually necessary. +(cl-defmethod gnus-search-run-search :around ((_e gnus-search-namazu) + _server _query _groups) + (let ((process-environment (copy-sequence process-environment))) + (setenv "LC_MESSAGES" "C") + (cl-call-next-method))) + +(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-namazu) + (qstring string) + query &optional _groups) + (let ((max (alist-get 'limit query))) + (with-slots (switches index-directory) engine + (append + (list "-q" ; don't be verbose + "-a" ; show all matches + "-s") ; use short format + (when max (list (format "--max=%d" max))) + switches + (list qstring index-directory))))) + +(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-namazu)) + "Extract a single message result for Namazu. +Namazu provides a little more information, for instance a score." + + (when (re-search-forward + "^\\([0-9,]+\\.\\).*\\((score: \\([0-9]+\\)\\))\n\\([^ ]+\\)" + nil t) + (list (match-string 4) + (match-string 3)))) + +;;; Notmuch interface + +(cl-defmethod gnus-search-transform ((_engine gnus-search-notmuch) + (_query null)) + "*") + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-notmuch) + (expr (head near))) + (format "%s near %s" + (gnus-search-transform-expression engine (nth 1 expr)) + (gnus-search-transform-expression engine (nth 2 expr)))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-notmuch) + (expr list)) + ;; Swap keywords as necessary. + (cl-case (car expr) + (sender (setcar expr 'from)) + ;; Notmuch's "to" is already equivalent to our "recipient". + (recipient (setcar expr 'to)) + (mark (setcar expr 'tag))) + ;; Then actually format the results. + (cl-flet ((notmuch-date (date) + (if (stringp date) + date + (pcase date + (`(nil ,m nil) + (nth (1- m) gnus-english-month-names)) + (`(nil nil ,y) + (number-to-string y)) + (`(,d ,m nil) + (format "%02d-%02d" d m)) + (`(nil ,m ,y) + (format "%02d-%d" m y)) + (`(,d ,m ,y) + (format "%d/%d/%d" m d y)))))) + (cond + ((consp (car expr)) + (format "(%s)" (gnus-search-transform engine expr))) + ((eql (car expr) 'address) + (gnus-search-transform engine `((or (from . ,(cdr expr)) + (to . ,(cdr expr)))))) + ((eql (car expr) 'body) + (cdr expr)) + ((memq (car expr) '(from to subject attachment mimetype tag id + thread folder path lastmod query property)) + ;; Notmuch requires message-id with no angle brackets. + (when (eql (car expr) 'id) + (setcdr + expr (replace-regexp-in-string "\\`<\\|>\\'" "" (cdr expr)))) + (format "%s:%s" (car expr) + (if (string-match "\\`\\*" (cdr expr)) + ;; Notmuch can only handle trailing asterisk + ;; wildcards, so strip leading asterisks. + (replace-match "" nil nil (cdr expr)) + (cdr expr)))) + ((eq (car expr) 'date) + (format "date:%s" (notmuch-date (cdr expr)))) + ((eq (car expr) 'before) + (format "date:..%s" (notmuch-date (cdr expr)))) + ((eq (car expr) 'since) + (format "date:%s.." (notmuch-date (cdr expr)))) + (t (ignore-errors (cl-call-next-method)))))) + +(cl-defmethod gnus-search-run-search :around ((engine gnus-search-notmuch) + server query groups) + "Handle notmuch's thread-search routine." + ;; Notmuch allows for searching threads, but only using its own + ;; thread ids. That means a thread search is a \"double-bounce\": + ;; once to find the relevant thread ids, and again to find the + ;; actual messages. This method performs the first \"bounce\". + (if (alist-get 'thread query) + (with-slots (program proc-buffer) engine + (let* ((qstring + (gnus-search-make-query-string engine query)) + (cp-list (gnus-search-indexed-search-command + engine qstring query groups)) + thread-ids proc) + (set-buffer proc-buffer) + (erase-buffer) + (setq proc (apply #'start-process (format "search-%s" server) + proc-buffer program cp-list)) + (while (process-live-p proc) + (accept-process-output proc)) + (while (re-search-forward "^thread:\\([^ ]+\\)" (point-max) t) + (push (match-string 1) thread-ids)) + (cl-call-next-method + engine server + ;; Completely replace the query with our new thread-based one. + (mapconcat (lambda (thrd) (concat "thread:" thrd)) + thread-ids " or ") + nil))) + (cl-call-next-method engine server query groups))) + +(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-notmuch) + (qstring string) + query &optional _groups) + ;; Theoretically we could use the GROUPS parameter to pass a + ;; --folder switch to notmuch, but I'm not confident of getting the + ;; format right. + (let ((limit (alist-get 'limit query)) + (thread (alist-get 'thread query))) + (with-slots (switches config-file) engine + `(,(format "--config=%s" config-file) + "search" + ,(if thread + "--output=threads" + "--output=files") + "--duplicate=1" ; I have found this necessary, I don't know why. + ,@switches + ,(if limit (format "--limit=%d" limit) "") + ,qstring + )))) + +;;; Mairix interface + +;; See the Gnus manual for why mairix searching is a bit weird. + +(cl-defmethod gnus-search-transform ((engine gnus-search-mairix) + (query list)) + "Transform QUERY for a Mairix engine. +Because Mairix doesn't accept parenthesized expressions, nor +\"or\" statements between different keys, results may differ from +other engines. We unpeel parenthesized expressions, and just +cross our fingers for the rest of it." + (let (clauses) + (mapc + (lambda (item) + (when-let ((expr (if (consp (car-safe item)) + (gnus-search-transform engine item) + (gnus-search-transform-expression engine item)))) + (push expr clauses))) + query) + (mapconcat #'identity (reverse clauses) " "))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-mairix) + (expr (head not))) + "Transform Mairix \"not\". +Mairix negation requires a \"~\" preceding string search terms, +and \"-\" before marks." + (let ((next (gnus-search-transform-expression engine (cadr expr)))) + (replace-regexp-in-string + ":" + (if (eql (caadr expr) 'mark) + ":-" + ":~") + next))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-mairix) + (expr (head or))) + "Handle Mairix \"or\" statement. +Mairix only accepts \"or\" expressions on homogenous keys. We +cast \"or\" expressions on heterogenous keys as \"and\", which +isn't quite right, but it's the best we can do. For date keys, +only keep one of the terms." + (let ((term1 (caadr expr)) + (term2 (caaddr expr)) + (val1 (gnus-search-transform-expression engine (nth 1 expr))) + (val2 (gnus-search-transform-expression engine (nth 2 expr)))) + (cond + ((or (listp term1) (listp term2)) + (concat val1 " " val2)) + ((and (member (symbol-name term1) gnus-search-date-keys) + (member (symbol-name term2) gnus-search-date-keys)) + (or val1 val2)) + ((eql term1 term2) + (if (and val1 val2) + (format "%s/%s" + val1 + (nth 1 (split-string val2 ":"))) + (or val1 val2))) + (t (concat val1 " " val2))))) + + +(cl-defmethod gnus-search-transform-expression ((_ gnus-search-mairix) + (expr (head mark))) + (gnus-search-mairix-handle-mark (cdr expr))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-mairix) + (expr list)) + (let ((key (cl-case (car expr) + (sender "f") + (from "f") + (to "t") + (cc "c") + (subject "s") + (id "m") + (body "b") + (address "a") + (recipient "tc") + (text "bs") + (attachment "n") + (t nil)))) + (cond + ((consp (car expr)) + (gnus-search-transform engine expr)) + ((member (symbol-name (car expr)) gnus-search-date-keys) + (gnus-search-mairix-handle-date expr)) + ((memq (car expr) '(size smaller larger)) + (gnus-search-mairix-handle-size expr)) + ;; Drop regular expressions. + ((string-match-p "\\`/" (cdr expr)) + nil) + ;; Turn parenthesized phrases into multiple word terms. Again, + ;; this isn't quite what the user is asking for, but better to + ;; return false positives. + ((and key (string-match-p "[[:blank:]]" (cdr expr))) + (mapconcat + (lambda (s) (format "%s:%s" key s)) + (split-string (gnus-search-mairix-treat-string + (cdr expr))) + " ")) + (key (format "%s:%s" key + (gnus-search-mairix-treat-string + (cdr expr)))) + (t nil)))) + +(defun gnus-search-mairix-treat-string (str) + "Treat string for wildcards. +Mairix accepts trailing wildcards, but not leading. Also remove +double quotes." + (replace-regexp-in-string + "\\`\\*\\|\"" "" + (replace-regexp-in-string "\\*\\'" "=" str))) + +(defun gnus-search-mairix-handle-size (expr) + "Format a mairix size search. +Assume \"size\" key is equal to \"larger\"." + (format + (if (eql (car expr) 'smaller) + "z:-%s" + "z:%s-") + (cdr expr))) + +(defun gnus-search-mairix-handle-mark (expr) + "Format a mairix mark search." + (let ((mark + (pcase (cdr expr) + ("flag" "f") + ("read" "s") + ("seen" "s") + ("replied" "r") + (_ nil)))) + (when mark + (format "F:%s" mark)))) + +(defun gnus-search-mairix-handle-date (expr) + (let ((str + (pcase (cdr expr) + (`(nil ,m nil) + (substring + (nth (1- m) gnus-english-month-names) + 0 3)) + (`(nil nil ,y) + (number-to-string y)) + (`(,d ,m nil) + (format "%s%02d" + (substring + (nth (1- m) gnus-english-month-names) + 0 3) + d)) + (`(nil ,m ,y) + (format "%d%s" + y (substring + (nth (1- m) gnus-english-month-names) + 0 3))) + (`(,d ,m ,y) + (format "%d%02d%02d" y m d))))) + (format + (pcase (car expr) + ('date "d:%s") + ('since "d:%s-") + ('after "d:%s-") + ('before "d:-%s")) + str))) + +(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-mairix) + (qstring string) + query &optional _groups) + (with-slots (switches config-file) engine + (append `("--rcfile" ,config-file "-r") + switches + (when (alist-get 'thread query) (list "-t")) + (list qstring)))) + +;;; Find-grep interface + +(cl-defmethod gnus-search-transform-expression ((_engine gnus-search-find-grep) + (_ list)) + ;; Drop everything that isn't a plain string. + nil) + +(cl-defmethod gnus-search-run-search ((engine gnus-search-find-grep) + server query + &optional groups) + "Run find and grep to obtain matching articles." + (let* ((method (gnus-server-to-method server)) + (sym (intern + (concat (symbol-name (car method)) "-directory"))) + (directory (cadr (assoc sym (cddr method)))) + (regexp (alist-get 'grep query)) + (grep-options (slot-value engine 'grep-options)) + (grouplist (or groups (gnus-search-get-active server))) + (buffer (slot-value engine 'proc-buffer))) + (unless directory + (error "No directory found in method specification of server %s" + server)) + (apply + 'vconcat + (mapcar (lambda (x) + (let ((group x) + artlist) + (message "Searching %s using find-grep..." + (or group server)) + (save-window-excursion + (set-buffer buffer) + (if (> gnus-verbose 6) + (pop-to-buffer (current-buffer))) + (cd directory) ; Using relative paths simplifies + ; postprocessing. + (let ((group + (if (not group) + "." + ;; Try accessing the group literally as + ;; well as interpreting dots as directory + ;; separators so the engine works with + ;; plain nnml as well as the Gnus Cache. + (let ((group (gnus-group-real-name group))) + ;; Replace cl-func find-if. + (if (file-directory-p group) + group + (if (file-directory-p + (setq group + (replace-regexp-in-string + "\\." "/" + group nil t))) + group)))))) + (unless group + (error "Cannot locate directory for group")) + (save-excursion + (apply + 'call-process "find" nil t + "find" group "-maxdepth" "1" "-type" "f" + "-name" "[0-9]*" "-exec" + (slot-value engine 'grep-program) + `("-l" ,@(and grep-options + (split-string grep-options "\\s-" t)) + "-e" ,regexp "{}" "+")))) + + ;; Translate relative paths to group names. + (while (not (eobp)) + (let* ((path (split-string + (buffer-substring + (point) + (line-end-position)) "/" t)) + (art (string-to-number (car (last path))))) + (while (string= "." (car path)) + (setq path (cdr path))) + (let ((group (mapconcat #'identity + (cl-subseq path 0 -1) + "."))) + (push + (vector (gnus-group-full-name group server) art 0) + artlist)) + (forward-line 1))) + (message "Searching %s using find-grep...done" + (or group server)) + artlist))) + grouplist)))) + +;;; Util Code: + +(defun gnus-search-run-query (specs) + "Invoke appropriate search engine function." + ;; For now, run the searches synchronously. At some point + ;; multiple-server searches can each be run in their own thread, + ;; allowing concurrent searches of multiple backends. At present + ;; this causes problems when searching more than one server that + ;; uses `nntp-server-buffer', as their return values are written + ;; interleaved into that buffer. Anyway, that's the reason for the + ;; `mapc'. + (let* ((results []) + (prepared-query (gnus-search-prepare-query + (alist-get 'search-query-spec specs))) + (limit (alist-get 'limit prepared-query))) + (mapc + (pcase-lambda (`(,server . ,groups)) + (let ((search-engine (gnus-search-server-to-engine server))) + (setq results + (vconcat + (gnus-search-run-search + search-engine server prepared-query groups) + results)))) + (alist-get 'search-group-spec specs)) + ;; Some search engines do their own limiting, but some don't, so + ;; do it again here. This is bad because, if the user is + ;; searching multiple groups, they would reasonably expect the + ;; limiting to apply to the search results *after sorting*. Doing + ;; it this way is liable to, for instance, eliminate all results + ;; from a later group entirely. + (if limit + (seq-subseq results 0 (min limit (length results))) + results))) + +(defun gnus-search-prepare-query (query-spec) + "Accept a search query in raw format, and prepare it. +QUERY-SPEC is an alist produced by functions such as +`gnus-group-make-search-group', and contains at least a 'query +key, and possibly some meta keys. This function extracts any +additional meta keys from the 'query string, and parses the +remaining string, then adds all that to the top-level spec." + (let ((query (alist-get 'query query-spec)) + val) + (when (stringp query) + ;; Look for these meta keys: + (while (string-match + "\\(thread\\|grep\\|limit\\|raw\\):\\([^ ]+\\)" + query) + (setq val (match-string 2 query)) + (setf (alist-get (intern (match-string 1 query)) query-spec) + ;; This is stupid. + (cond + ((equal val "t")) + ((null (zerop (string-to-number val))) + (string-to-number val)) + (t val))) + (setq query + (string-trim (replace-match "" t t query 0))) + (setf (alist-get 'query query-spec) query))) + (when (and gnus-search-use-parsed-queries + (null (alist-get 'raw query-spec))) + (setf (alist-get 'parsed-query query-spec) + (gnus-search-parse-query query))) + query-spec)) + +;; This should be done once at Gnus startup time, when the servers are +;; first opened, and the resulting engine instance attached to the +;; server. +(defun gnus-search-server-to-engine (srv) + (let* ((method (gnus-server-to-method srv)) + (engine-config (assoc 'gnus-search-engine (cddr method))) + (server (or (cdr-safe + (assoc-string srv gnus-search-engine-instance-alist t)) + (nth 1 engine-config) + (cdr-safe (assoc (car method) gnus-search-default-engines)) + (when-let ((old (assoc 'nnir-search-engine + (cddr method)))) + (nnheader-message + 8 "\"nnir-search-engine\" is no longer a valid parameter") + (nth 1 old)))) + inst) + (setq server + (pcase server + ('notmuch 'gnus-search-notmuch) + ('namazu 'gnus-search-namazu) + ('find-grep 'gnus-search-find-grep) + ('imap 'gnus-search-imap) + (_ server)) + inst + (cond + ((null server) nil) + ((eieio-object-p server) + server) + ((class-p server) + (make-instance server)) + (t nil))) + (if inst + (unless (assoc-string srv gnus-search-engine-instance-alist t) + (when (cddr engine-config) + ;; We're not being completely backward-compatible here, + ;; because we're not checking for nnir-specific config + ;; options in the server definition. + (pcase-dolist (`(,key ,value) (cddr engine-config)) + (condition-case nil + (setf (slot-value inst key) value) + ((invalid-slot-name invalid-slot-type) + (nnheader-message + 5 "Invalid search engine parameter: (%s %s)" + key value))))) + (push (cons srv inst) gnus-search-engine-instance-alist)) + (error "No search engine defined for %s" srv)) + inst)) + +(declare-function gnus-registry-get-id-key "gnus-registry" (id key)) + +(defun gnus-search-thread (header) + "Make an nnselect group based on the thread containing the article +header. The current server will be searched. If the registry is +installed, the server that the registry reports the current +article came from is also searched." + (let* ((ids (cons (mail-header-id header) + (split-string + (or (mail-header-references header) + "")))) + (query + (list (cons 'query (mapconcat (lambda (i) + (format "id:%s" i)) + ids " or ")) + (cons 'thread t))) + (server + (list (list (gnus-method-to-server + (gnus-find-method-for-group gnus-newsgroup-name))))) + (registry-group (and + (bound-and-true-p gnus-registry-enabled) + (car (gnus-registry-get-id-key + (mail-header-id header) 'group)))) + (registry-server + (and registry-group + (gnus-method-to-server + (gnus-find-method-for-group registry-group))))) + (when registry-server + (cl-pushnew (list registry-server) server :test #'equal)) + (gnus-group-make-search-group nil (list + (cons 'search-query-spec query) + (cons 'search-group-spec server))) + (gnus-summary-goto-subject (gnus-id-to-article (mail-header-id header))))) + +(defun gnus-search-get-active (srv) + (let ((method (gnus-server-to-method srv)) + groups) + (gnus-request-list method) + (with-current-buffer nntp-server-buffer + (let ((cur (current-buffer))) + (goto-char (point-min)) + (unless (or (null gnus-search-ignored-newsgroups) + (string= gnus-search-ignored-newsgroups "")) + (delete-matching-lines gnus-search-ignored-newsgroups)) + (if (eq (car method) 'nntp) + (while (not (eobp)) + (ignore-errors + (push (gnus-group-decoded-name + (gnus-group-full-name + (buffer-substring + (point) + (progn + (skip-chars-forward "^ \t") + (point))) + method)) + groups)) + (forward-line)) + (while (not (eobp)) + (ignore-errors + (push (gnus-group-decoded-name + (if (eq (char-after) ?\") + (gnus-group-full-name (read cur) method) + (let ((p (point)) (name "")) + (skip-chars-forward "^ \t\\\\") + (setq name (buffer-substring p (point))) + (while (eq (char-after) ?\\) + (setq p (1+ (point))) + (forward-char 2) + (skip-chars-forward "^ \t\\\\") + (setq name (concat name (buffer-substring + p (point))))) + (gnus-group-full-name name method)))) + groups)) + (forward-line))))) + groups)) + +(defvar gnus-search-minibuffer-map + (let ((km (make-sparse-keymap))) + (set-keymap-parent km minibuffer-local-map) + (define-key km (kbd "TAB") #'completion-at-point) + km)) + +(defun gnus-search--complete-key-data () + "Potentially return completion data for a search key or value." + (let* ((key-start (save-excursion + (or (re-search-backward " " (minibuffer-prompt-end) t) + (goto-char (minibuffer-prompt-end))) + (skip-chars-forward " -") + (point))) + (after-colon (save-excursion + (when (re-search-backward ":" key-start t) + (1+ (point))))) + in-string) + (if after-colon + ;; We're in the value part of a key:value pair, which we + ;; only handle in a contact-completion context. + (when (and gnus-search-contact-tables + (save-excursion + (re-search-backward "\\<-?\\(\\w+\\):" key-start t) + (member (match-string 1) + '("from" "to" "cc" + "bcc" "recipient" "address")))) + (setq in-string (nth 3 (syntax-ppss))) + (list (if in-string (1+ after-colon) after-colon) + (point) (apply #'completion-table-merge + gnus-search-contact-tables) + :exit-function + (lambda (str status) + ;; If the value contains spaces, make sure it's + ;; quoted. + (when (and (memql status '(exact finished)) + (or (string-match-p " " str) + in-string)) + (unless (looking-at-p "\\s\"") + (insert "\"")) + ;; Unless we already have an opening quote... + (unless in-string + (save-excursion + (goto-char after-colon) + (insert "\""))))))) + (list + key-start (point) gnus-search-expandable-keys + :exit-function (lambda (_s status) + (when (memql status '(exact finished)) + (insert ":"))))))) + +(defun gnus-search-make-spec (arg) + (list (cons 'query + (minibuffer-with-setup-hook + (lambda () + (add-hook 'completion-at-point-functions + #'gnus-search--complete-key-data + nil t)) + (read-from-minibuffer + "Query: " nil gnus-search-minibuffer-map + nil 'gnus-search-history))) + (cons 'raw arg))) + +(provide 'gnus-search) +;;; gnus-search.el ends here diff --git a/lisp/gnus/gnus-sieve.el b/lisp/gnus/gnus-sieve.el index 278e3a5d6f3..5d8f9b55deb 100644 --- a/lisp/gnus/gnus-sieve.el +++ b/lisp/gnus/gnus-sieve.el @@ -29,8 +29,6 @@ (require 'gnus) (require 'gnus-sum) -(require 'format-spec) -(autoload 'sieve-mode "sieve-mode") (eval-when-compile (require 'sieve)) @@ -88,10 +86,10 @@ See the documentation for these variables and functions for details." (save-buffer) (shell-command (format-spec gnus-sieve-update-shell-command - (format-spec-make ?f gnus-sieve-file - ?s (or (cadr (gnus-server-get-method - nil gnus-sieve-select-method)) - ""))))) + `((?f . ,gnus-sieve-file) + (?s . ,(or (cadr (gnus-server-get-method + nil gnus-sieve-select-method)) + "")))))) ;;;###autoload (defun gnus-sieve-generate () diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index d58bd7a73b5..6beb543e5a1 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -34,7 +34,7 @@ (require 'gnus-range) (require 'gnus-cloud) -(autoload 'gnus-group-make-nnir-group "nnir") +(autoload 'gnus-group-read-ephemeral-search-group "nnselect") (defcustom gnus-server-exit-hook nil "Hook run when exiting the server buffer." @@ -176,7 +176,7 @@ If nil, a faster, but more primitive, buffer is used instead." "g" gnus-server-regenerate-server - "G" gnus-group-make-nnir-group + "G" gnus-group-read-ephemeral-search-group "z" gnus-server-compact-server @@ -309,7 +309,7 @@ The following commands are available: ;; `gnus-server-buffer' selected as the current buffer, but not always (I ;; bumped into it when starting from a dedicated *Group* frame, and ;; gnus-configure-windows opened *Server* into its own dedicated frame). - (with-current-buffer (get-buffer-create gnus-server-buffer) + (with-current-buffer (gnus-get-buffer-create gnus-server-buffer) (gnus-server-mode) (gnus-server-prepare))) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index dbe92a164d0..615f8dfa877 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -31,6 +31,7 @@ (require 'gnus-range) (require 'gnus-util) (require 'gnus-cloud) +(require 'gnus-dbus) (autoload 'message-make-date "message") (autoload 'gnus-agent-read-servers-validate "gnus-agent") (autoload 'gnus-agent-save-local "gnus-agent") @@ -730,7 +731,7 @@ the first newsgroup." ;; Remove Gnus frames. (gnus-kill-gnus-frames)) -(defun gnus-no-server-1 (&optional arg slave) +(defun gnus-no-server-1 (&optional arg child) "Read network news. If ARG is a positive number, Gnus will use that as the startup level. If ARG is nil, Gnus will be started at level 2 @@ -739,11 +740,11 @@ and not a positive number, Gnus will prompt the user for the name of an NNTP server to use. As opposed to \\[gnus], this command will not connect to the local server." (let ((val (or arg (1- gnus-level-default-subscribed)))) - (gnus val t slave) + (gnus val t child) (make-local-variable 'gnus-group-use-permanent-levels) (setq gnus-group-use-permanent-levels val))) -(defun gnus-1 (&optional arg dont-connect slave) +(defun gnus-1 (&optional arg dont-connect child) "Read network news. If ARG is non-nil and a positive number, Gnus will use that as the startup level. If ARG is non-nil and not a positive number, Gnus will @@ -761,7 +762,7 @@ prompt the user for the name of an NNTP server to use." (gnus-splash) (gnus-run-hooks 'gnus-before-startup-hook) (nnheader-init-server-buffer) - (setq gnus-slave slave) + (setq gnus-child child) (gnus-read-init-file) ;; Add "native" to gnus-predefined-server-alist just to have a @@ -790,7 +791,7 @@ prompt the user for the name of an NNTP server to use." (gnus-make-newsrc-file gnus-startup-file)) ;; Read the dribble file. - (when (or gnus-slave gnus-use-dribble-file) + (when (or gnus-child gnus-use-dribble-file) (gnus-dribble-read-file)) ;; Do the actual startup. @@ -798,6 +799,8 @@ prompt the user for the name of an NNTP server to use." (gnus-run-hooks 'gnus-setup-news-hook) (when gnus-agent (gnus-request-create-group "queue" '(nndraft ""))) + (when gnus-dbus-close-on-sleep + (gnus-dbus-register-sleep-signal)) (gnus-start-draft-setup) ;; Generate the group buffer. (gnus-group-list-groups level) @@ -1008,11 +1011,11 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." ;; Possibly eval the dribble file. (and init - (or gnus-use-dribble-file gnus-slave) + (or gnus-use-dribble-file gnus-child) (gnus-dribble-eval-file)) - ;; Slave Gnusii should then clear the dribble buffer. - (when (and init gnus-slave) + ;; Child Gnusii should then clear the dribble buffer. + (when (and init gnus-child) (gnus-dribble-clear)) (gnus-update-format-specifications) @@ -1030,7 +1033,7 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." ;; Find new newsgroups and treat them. (when (and init gnus-check-new-newsgroups (not level) (gnus-check-server gnus-select-method) - (not gnus-slave) + (not gnus-child) gnus-plugged) (gnus-find-new-newsgroups)) @@ -1040,8 +1043,8 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." (gnus-server-opened gnus-select-method)) (gnus-check-bogus-newsgroups)) - ;; Read any slave files. - (gnus-master-read-slave-newsrc) + ;; Read any child files. + (gnus-parent-read-child-newsrc) ;; Find the number of unread articles in each non-dead group. (let ((gnus-read-active-file (and (not level) gnus-read-active-file))) @@ -1256,19 +1259,19 @@ INFO-LIST), otherwise it's a list in the format of the `gnus-newsrc-hashtb' entries. LEVEL is the new level of the group, OLDLEVEL is the old level and PREVIOUS is the group (a string name) to insert this group before." - (let (group info active num) - ;; Glean what info we can from the arguments. - (if (consp entry) - (setq group (if fromkilled (nth 1 entry) (car (nth 1 entry)))) - (setq group entry)) + ;; Glean what info we can from the arguments. + (let ((group (if (consp entry) + (if fromkilled (nth 1 entry) (car (nth 1 entry))) + entry)) + info active num) (when (and (stringp entry) oldlevel (< oldlevel gnus-level-zombie)) (setq entry (gnus-group-entry entry))) - (if (and (not oldlevel) - (consp entry)) - (setq oldlevel (gnus-info-level (nth 1 entry))) - (setq oldlevel (or oldlevel gnus-level-killed))) + (setq oldlevel (if (and (not oldlevel) + (consp entry)) + (gnus-info-level (nth 1 entry)) + (or oldlevel gnus-level-killed))) ;; This table is used for completion, so put a dummy entry there. (unless (gethash group gnus-active-hashtb) @@ -1799,7 +1802,7 @@ backend check whether the group actually exists." ;; by one. (t (dolist (info infos) - (gnus-activate-group (gnus-info-group info) nil nil method t)))))) + (gnus-activate-group (gnus-info-group info) t nil method t)))))) (defun gnus-make-hashtable-from-newsrc-alist () "Create a hash table from `gnus-newsrc-alist'. @@ -2111,6 +2114,7 @@ The info element is shared with the same element of ((string= gnus-ignored-newsgroups "") (delete-matching-lines "^to\\.")) (t + ;; relint suppression: Duplicated alternative branch (delete-matching-lines (concat "^to\\.\\|" gnus-ignored-newsgroups)))) (goto-char (point-min)) @@ -2737,15 +2741,15 @@ values from `gnus-newsrc-hashtb', and write a new value of (gnus-agent-save-local force)) (save-excursion - (if (and (or gnus-use-dribble-file gnus-slave) + (if (and (or gnus-use-dribble-file gnus-child) (not force) (or (not (buffer-live-p gnus-dribble-buffer)) (zerop (with-current-buffer gnus-dribble-buffer (buffer-size))))) (gnus-message 4 "(No changes need to be saved)") (gnus-run-hooks 'gnus-save-newsrc-hook) - (if gnus-slave - (gnus-slave-save-newsrc) + (if gnus-child + (gnus-child-save-newsrc) ;; Save .newsrc only if the select method is an NNTP method. ;; The .newsrc file is for interoperability with other ;; newsreaders, so saving non-NNTP groups there doesn't make @@ -2812,7 +2816,7 @@ values from `gnus-newsrc-hashtb', and write a new value of (file-exists-p working-file))) (unwind-protect - (progn + (with-file-modes (file-modes startup-file) (gnus-with-output-to-file working-file (gnus-gnus-to-quick-newsrc-format) (gnus-run-hooks 'gnus-save-quick-newsrc-hook)) @@ -2822,14 +2826,12 @@ values from `gnus-newsrc-hashtb', and write a new value of ;; file. (let ((buffer-backed-up nil) (buffer-file-name startup-file) - (file-precious-flag t) - (setmodes (file-modes startup-file))) + (file-precious-flag t)) ;; Backup the current version of the startup file. (backup-buffer) ;; Replace the existing startup file with the temp file. (rename-file working-file startup-file t) - (gnus-set-file-modes startup-file setmodes) (setq gnus-save-newsrc-file-last-timestamp (file-attribute-modification-time (file-attributes startup-file))))) @@ -2990,55 +2992,61 @@ SPECIFIC-VARIABLES, or those in `gnus-variable-list'." ;;; -;;; Slave functions. +;;; Child functions. ;;; -(defvar gnus-slave-mode nil) +(defvar gnus-child-mode nil) -(defun gnus-slave-mode () - "Minor mode for slave Gnusae." - ;; FIXME: gnus-slave-mode appears to never be set (i.e. it'll always be nil): +(defun gnus-child-mode () + "Minor mode for child Gnusae." + ;; FIXME: gnus-child-mode appears to never be set (i.e. it'll always be nil): ;; Remove, or fix and use define-minor-mode. - (add-minor-mode 'gnus-slave-mode " Slave" (make-sparse-keymap)) - (gnus-run-hooks 'gnus-slave-mode-hook)) + (add-minor-mode 'gnus-child-mode " Child" (make-sparse-keymap)) + (gnus-run-hooks 'gnus-child-mode-hook)) -(defun gnus-slave-save-newsrc () +(define-obsolete-function-alias 'gnus-slave-mode #'gnus-child-mode "28.1") +(define-obsolete-variable-alias 'gnus-slave-mode-hook 'gnus-child-mode-hook + "28.1") + +(defun gnus-child-save-newsrc () (with-current-buffer gnus-dribble-buffer - (let ((slave-name - (make-temp-file (concat gnus-current-startup-file "-slave-"))) - (modes (ignore-errors - (file-modes (concat gnus-current-startup-file ".eld"))))) - (let ((coding-system-for-write gnus-ding-file-coding-system)) - (gnus-write-buffer slave-name)) - (when modes - (gnus-set-file-modes slave-name modes))))) - -(defun gnus-master-read-slave-newsrc () - (let ((slave-files + (with-file-modes (or (ignore-errors + (file-modes + (concat gnus-current-startup-file ".eld"))) + (default-file-modes)) + (let ((child-name + (make-temp-file (concat gnus-current-startup-file "-child-")))) + (let ((coding-system-for-write gnus-ding-file-coding-system)) + (gnus-write-buffer child-name)))))) + +(defun gnus-parent-read-child-newsrc () + (let ((child-files (directory-files (file-name-directory gnus-current-startup-file) t (concat "^" (regexp-quote - (concat - (file-name-nondirectory gnus-current-startup-file) - "-slave-"))) + (file-name-nondirectory gnus-current-startup-file)) + ;; When the obsolete variables like + ;; `gnus-slave-mode-hook' etc are removed, the "slave" + ;; bit of this regexp should also be removed. + "\\(-child-\\|-slave-\\)") t)) file) - (if (not slave-files) - () ; There are no slave files to read. - (gnus-message 7 "Reading slave newsrcs...") - (with-current-buffer (gnus-get-buffer-create " *gnus slave*") - (setq slave-files + (if (not child-files) + () ; There are no child files to read. + (gnus-message 7 "Reading child newsrcs...") + (with-current-buffer (gnus-get-buffer-create " *gnus child*") + (setq child-files (sort (mapcar (lambda (file) (list (file-attribute-modification-time (file-attributes file)) file)) - slave-files) + child-files) (lambda (f1 f2) (time-less-p (car f1) (car f2))))) - (while slave-files + (while child-files (erase-buffer) - (setq file (nth 1 (car slave-files))) + (setq file (nth 1 (car child-files))) (nnheader-insert-file-contents file) (when (condition-case () (progn @@ -3047,12 +3055,12 @@ SPECIFIC-VARIABLES, or those in `gnus-variable-list'." (error (gnus-error 3.2 "Possible error in %s" file) nil)) - (unless gnus-slave ; Slaves shouldn't delete these files. + (unless gnus-child ; Children shouldn't delete these files. (ignore-errors (delete-file file)))) - (setq slave-files (cdr slave-files)))) + (setq child-files (cdr child-files)))) (gnus-dribble-touch) - (gnus-message 7 "Reading slave newsrcs...done")))) + (gnus-message 7 "Reading child newsrcs...done")))) ;;; diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 9b11d5878d9..561f199531e 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -85,8 +85,9 @@ (autoload 'gnus-article-outlook-unwrap-lines "deuglify" nil t) (autoload 'gnus-article-outlook-repair-attribution "deuglify" nil t) (autoload 'gnus-article-outlook-rearrange-citation "deuglify" nil t) -(autoload 'nnir-article-rsv "nnir" nil nil 'macro) -(autoload 'nnir-article-group "nnir" nil nil 'macro) +(autoload 'nnselect-article-rsv "nnselect" nil nil) +(autoload 'nnselect-article-group "nnselect" nil nil) +(autoload 'gnus-nnselect-group-p "nnselect" nil nil) (defcustom gnus-kill-summary-on-exit t "If non-nil, kill the summary buffer when you exit from it. @@ -144,11 +145,14 @@ If t, fetch all the available old headers." :type '(choice number (sexp :menu-tag "other" t))) -(defcustom gnus-refer-thread-use-nnir nil - "Use nnir to search an entire server when referring threads. +(define-obsolete-variable-alias 'gnus-refer-thread-use-nnir + 'gnus-refer-thread-use-search "28.1") + +(defcustom gnus-refer-thread-use-search nil + "Search an entire server when referring threads. A nil value will only search for thread-related articles in the current group." - :version "24.1" + :version "28.1" :group 'gnus-thread :type 'boolean) @@ -884,6 +888,7 @@ controls how articles are sorted." (function-item gnus-article-sort-by-subject) (function-item gnus-article-sort-by-date) (function-item gnus-article-sort-by-score) + (function-item gnus-article-sort-by-rsv) (function-item gnus-article-sort-by-random) (function :tag "other")) (boolean :tag "Reverse order")))) @@ -927,6 +932,7 @@ subthreads, customize `gnus-subthread-sort-functions'." (function-item gnus-thread-sort-by-subject) (function-item gnus-thread-sort-by-date) (function-item gnus-thread-sort-by-score) + (function-item gnus-thread-sort-by-rsv) (function-item gnus-thread-sort-by-most-recent-number) (function-item gnus-thread-sort-by-most-recent-date) (function-item gnus-thread-sort-by-random) @@ -1433,16 +1439,13 @@ the normal Gnus MIME machinery." (?c (or (mail-header-chars gnus-tmp-header) 0) ?d) (?k (gnus-summary-line-message-size gnus-tmp-header) ?s) (?L gnus-tmp-lines ?s) - (?Z (or (nnir-article-rsv (mail-header-number gnus-tmp-header)) - 0) - ?d) - (?G (or (nnir-article-group (mail-header-number gnus-tmp-header)) - "") - ?s) + (?Z (or (nnselect-article-rsv (mail-header-number gnus-tmp-header)) + 0) ?d) + (?G (or (nnselect-article-group (mail-header-number gnus-tmp-header)) + "") ?s) (?g (or (gnus-group-short-name - (nnir-article-group (mail-header-number gnus-tmp-header))) - "") - ?s) + (nnselect-article-group (mail-header-number gnus-tmp-header))) + "") ?s) (?O gnus-tmp-downloaded ?c) (?I gnus-tmp-indentation ?s) (?T (if (= gnus-tmp-level 0) "" (make-string (frame-width) ? )) ?s) @@ -1501,9 +1504,9 @@ the type of the variable (string, integer, character, etc).") ;; This is here rather than in gnus-art for compilation reasons. (defvar gnus-article-mode-line-format-alist - (nconc '((?w (gnus-article-wash-status) ?s) - (?m (gnus-article-mime-part-status) ?s)) - gnus-summary-mode-line-format-alist)) + (append '((?w (gnus-article-wash-status) ?s) + (?m (gnus-article-mime-part-status) ?s)) + gnus-summary-mode-line-format-alist)) (defvar gnus-last-search-regexp nil "Default regexp for article search command.") @@ -1619,6 +1622,8 @@ This list will always be a subset of gnus-newsgroup-undownloaded.") (defvar gnus-newsgroup-sparse nil) +(defvar gnus-newsgroup-selection nil) + (defvar gnus-current-article nil) (defvar gnus-article-current nil) (defvar gnus-current-headers nil) @@ -1653,6 +1658,8 @@ This list will always be a subset of gnus-newsgroup-undownloaded.") gnus-newsgroup-undownloaded gnus-newsgroup-unsendable + gnus-newsgroup-selection + gnus-newsgroup-begin gnus-newsgroup-end gnus-newsgroup-last-rmail gnus-newsgroup-last-mail gnus-newsgroup-last-folder gnus-newsgroup-last-file @@ -1913,7 +1920,8 @@ increase the score of each group you read." "," gnus-summary-best-unread-article "[" gnus-summary-prev-unseen-article "]" gnus-summary-next-unseen-article - "\M-s" gnus-summary-search-article-forward + "\M-s\M-s" gnus-summary-search-article-forward + "\M-s\M-r" gnus-summary-search-article-backward "\M-r" gnus-summary-search-article-backward "\M-S" gnus-summary-repeat-search-article-forward "\M-R" gnus-summary-repeat-search-article-backward @@ -1982,6 +1990,7 @@ increase the score of each group you read." "\M-K" gnus-summary-edit-global-kill ;; "V" gnus-version "\C-c\C-d" gnus-summary-describe-group + "\C-c\C-p" gnus-summary-make-group-from-search "q" gnus-summary-exit "Q" gnus-summary-exit-no-update "\C-c\C-i" gnus-info-find-node @@ -4531,48 +4540,14 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." ;; This function has to be called with point after the article number ;; on the beginning of the line. (defsubst gnus-nov-parse-line (number dependencies &optional force-new) - (let ((eol (point-at-eol)) - header references in-reply-to) - + (let (header) ;; overview: [num subject from date id refs chars lines misc] (unwind-protect - (let (x) - (narrow-to-region (point) eol) - (unless (eobp) - (forward-char)) - - (setq header - (make-full-mail-header - number ; number - (condition-case () ; subject - (gnus-remove-odd-characters - (funcall gnus-decode-encoded-word-function - (setq x (nnheader-nov-field)))) - (error x)) - (condition-case () ; from - (gnus-remove-odd-characters - (funcall gnus-decode-encoded-address-function - (setq x (nnheader-nov-field)))) - (error x)) - (nnheader-nov-field) ; date - (nnheader-nov-read-message-id number) ; id - (setq references (nnheader-nov-field)) ; refs - (nnheader-nov-read-integer) ; chars - (nnheader-nov-read-integer) ; lines - (unless (eobp) - (if (looking-at "Xref: ") - (goto-char (match-end 0))) - (nnheader-nov-field)) ; Xref - (nnheader-nov-parse-extra)))) ; extra - + (narrow-to-region (point) (point-at-eol)) + (unless (eobp) + (forward-char)) + (setq header (nnheader-parse-nov number)) (widen)) - - (when (and (string= references "") - (setq in-reply-to (mail-header-extra header)) - (setq in-reply-to (cdr (assq 'In-Reply-To in-reply-to)))) - (setf (mail-header-references header) - (gnus-extract-message-id-from-in-reply-to in-reply-to))) - (when gnus-alter-header-function (funcall gnus-alter-header-function header)) (gnus-dependencies-add-header header dependencies force-new))) @@ -5103,6 +5078,17 @@ using some other form will lead to serious barfage." (gnus-article-sort-by-date (gnus-thread-header h1) (gnus-thread-header h2))) +(defsubst gnus-article-sort-by-rsv (h1 h2) + "Sort articles by rsv." + (when gnus-newsgroup-selection + (< (nnselect-article-rsv (mail-header-number h1)) + (nnselect-article-rsv (mail-header-number h2))))) + +(defun gnus-thread-sort-by-rsv (h1 h2) + "Sort threads by root article rsv." + (gnus-article-sort-by-rsv + (gnus-thread-header h1) (gnus-thread-header h2))) + (defsubst gnus-article-sort-by-score (h1 h2) "Sort articles by root article score. Unscored articles will be counted as having a score of zero." @@ -5352,7 +5338,8 @@ or a straight list of headers." ;; We remember that we probably want to output a dummy ;; root. (setq gnus-tmp-dummy-line gnus-tmp-header) - (setq gnus-tmp-prev-subject gnus-tmp-header)) + (setq gnus-tmp-prev-subject + (gnus-simplify-subject-fully gnus-tmp-header))) (t ;; We do not make a root for the gathered ;; sub-threads at all. @@ -5632,22 +5619,32 @@ or a straight list of headers." "Fetch headers of ARTICLES." (gnus-message 7 "Fetching headers for %s..." gnus-newsgroup-name) (prog1 - (if (eq 'nov - (setq gnus-headers-retrieved-by - (gnus-retrieve-headers - articles gnus-newsgroup-name - (or limit - ;; We might want to fetch old headers, but - ;; not if there is only 1 article. - (and (or (and - (not (eq gnus-fetch-old-headers 'some)) - (not (numberp gnus-fetch-old-headers))) - (> (length articles) 1)) - gnus-fetch-old-headers))))) - (gnus-get-newsgroup-headers-xover - articles force-new dependencies gnus-newsgroup-name t) - (gnus-get-newsgroup-headers dependencies force-new)) - (gnus-message 7 "Fetching headers for %s...done" gnus-newsgroup-name))) + (pcase (setq gnus-headers-retrieved-by + (gnus-retrieve-headers + articles gnus-newsgroup-name + (or limit + ;; We might want to fetch old headers, but + ;; not if there is only 1 article. + (and (or (and + (not (eq gnus-fetch-old-headers 'some)) + (not (numberp gnus-fetch-old-headers))) + (> (length articles) 1)) + gnus-fetch-old-headers)))) + ('nov + (gnus-get-newsgroup-headers-xover + articles force-new dependencies gnus-newsgroup-name t)) + ('headers + (gnus-get-newsgroup-headers dependencies force-new)) + ((pred listp) + (let ((dependencies + (or dependencies + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-dependencies)))) + (delq nil (mapcar #'(lambda (header) + (gnus-dependencies-add-header + header dependencies force-new)) + gnus-headers-retrieved-by))))) + (gnus-message 7 "Fetching headers for %s...done" gnus-newsgroup-name))) (defun gnus-select-newsgroup (group &optional read-all select-articles) "Select newsgroup GROUP. @@ -5937,7 +5934,9 @@ If SELECT-ARTICLES, only select those articles from GROUP." (initial (gnus-parameter-large-newsgroup-initial gnus-newsgroup-name)) (default (if only-read-p - (or initial gnus-large-newsgroup) + (if (eq initial 'all) + nil + (or initial gnus-large-newsgroup)) number)) (input (read-string @@ -6241,8 +6240,8 @@ If WHERE is `summary', the summary mode line format will be used." ;; We might have to chop a bit of the string off... (when (> (length mode-string) max-len) (setq mode-string - (concat (truncate-string-to-width mode-string (- max-len 3)) - "..."))))) + (truncate-string-to-width + mode-string (- max-len 3) nil nil t))))) ;; Update the mode line. (setq mode-line-buffer-identification (gnus-mode-line-buffer-identification (list mode-string))) @@ -6401,12 +6400,11 @@ The resulting hash table is returned, or nil if no Xrefs were found." (gnus-group-update-group group t)))))) (defun gnus-get-newsgroup-headers (&optional dependencies force-new) - (let ((cur nntp-server-buffer) - (dependencies + (let ((dependencies (or dependencies (with-current-buffer gnus-summary-buffer gnus-newsgroup-dependencies))) - headers id end ref number + headers (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets (save-current-buffer (condition-case nil @@ -6414,146 +6412,15 @@ The resulting hash table is returned, or nil if no Xrefs were found." (error)) gnus-newsgroup-ignored-charsets))) (with-current-buffer nntp-server-buffer - ;; Translate all TAB characters into SPACE characters. - (subst-char-in-region (point-min) (point-max) ?\t ? t) - (subst-char-in-region (point-min) (point-max) ?\r ? t) - (ietf-drums-unfold-fws) (gnus-run-hooks 'gnus-parse-headers-hook) - (let ((case-fold-search t) - in-reply-to header p lines chars) + (let ((nnmail-extra-headers gnus-extra-headers) + header) (goto-char (point-min)) - ;; Search to the beginning of the next header. Error messages - ;; do not begin with 2 or 3. - (while (re-search-forward "^[23][0-9]+ " nil t) - (setq id nil - ref nil) - ;; This implementation of this function, with nine - ;; search-forwards instead of the one re-search-forward and - ;; a case (which basically was the old function) is actually - ;; about twice as fast, even though it looks messier. You - ;; can't have everything, I guess. Speed and elegance - ;; doesn't always go hand in hand. - (setq - header - (make-full-mail-header - ;; Number. - (prog1 - (setq number (read cur)) - (end-of-line) - (setq p (point)) - (narrow-to-region (point) - (or (and (search-forward "\n.\n" nil t) - (- (point) 2)) - (point)))) - ;; Subject. - (progn - (goto-char p) - (if (search-forward "\nsubject:" nil t) - (funcall gnus-decode-encoded-word-function - (nnheader-header-value)) - "(none)")) - ;; From. - (progn - (goto-char p) - (if (search-forward "\nfrom:" nil t) - (funcall gnus-decode-encoded-address-function - (nnheader-header-value)) - "(nobody)")) - ;; Date. - (progn - (goto-char p) - (if (search-forward "\ndate:" nil t) - (nnheader-header-value) "")) - ;; Message-ID. - (progn - (goto-char p) - (setq id (if (re-search-forward - "^message-id: *\\(<[^\n\t> ]+>\\)" nil t) - ;; We do it this way to make sure the Message-ID - ;; is (somewhat) syntactically valid. - (buffer-substring (match-beginning 1) - (match-end 1)) - ;; If there was no message-id, we just fake one - ;; to make subsequent routines simpler. - (nnheader-generate-fake-message-id number)))) - ;; References. - (progn - (goto-char p) - (if (search-forward "\nreferences:" nil t) - (progn - (setq end (point)) - (prog1 - (nnheader-header-value) - (setq ref - (buffer-substring - (progn - (end-of-line) - (search-backward ">" end t) - (1+ (point))) - (progn - (search-backward "<" end t) - (point)))))) - ;; Get the references from the in-reply-to header if there - ;; were no references and the in-reply-to header looks - ;; promising. - (if (and (search-forward "\nin-reply-to:" nil t) - (setq in-reply-to (nnheader-header-value)) - (string-match "<[^>]+>" in-reply-to)) - (let (ref2) - (setq ref (substring in-reply-to (match-beginning 0) - (match-end 0))) - (while (string-match "<[^>]+>" in-reply-to (match-end 0)) - (setq ref2 (substring in-reply-to (match-beginning 0) - (match-end 0))) - (when (> (length ref2) (length ref)) - (setq ref ref2))) - ref) - (setq ref nil)))) - ;; Chars. - (progn - (goto-char p) - (if (search-forward "\nchars: " nil t) - (if (numberp (setq chars (ignore-errors (read cur)))) - chars -1) - -1)) - ;; Lines. - (progn - (goto-char p) - (if (search-forward "\nlines: " nil t) - (if (numberp (setq lines (ignore-errors (read cur)))) - lines -1) - -1)) - ;; Xref. - (progn - (goto-char p) - (and (search-forward "\nxref:" nil t) - (nnheader-header-value))) - ;; Extra. - (when gnus-extra-headers - (let ((extra gnus-extra-headers) - out) - (while extra - (goto-char p) - (when (search-forward - (concat "\n" (symbol-name (car extra)) ":") nil t) - (push (cons (car extra) (nnheader-header-value)) - out)) - (pop extra)) - out)))) - (when (equal id ref) - (setq ref nil)) - - (when gnus-alter-header-function - (funcall gnus-alter-header-function header) - (setq id (mail-header-id header) - ref (gnus-parent-id (mail-header-references header)))) - + (while (setq header (nnheader-parse-head)) (when (setq header (gnus-dependencies-add-header header dependencies force-new)) - (push header headers)) - (goto-char (point-max)) - (widen)) + (push header headers))) (nreverse headers))))) ;; Goes through the xover lines and returns a list of vectors @@ -7255,6 +7122,21 @@ The prefix argument ALL means to select all articles." (setq info (copy-sequence (gnus-get-info group)) info (delq (gnus-info-params info) info)))))))))) +(defun gnus-summary-make-group-from-search () + "Make a persistent group from the current ephemeral search group." + (interactive) + (if (not (gnus-nnselect-group-p gnus-newsgroup-name)) + (gnus-message 3 "%s is not a search group" gnus-newsgroup-name) + (let ((name (gnus-read-group "Group name: "))) + (with-current-buffer gnus-group-buffer + (gnus-group-make-group + name + (list 'nnselect "nnselect") + nil + (list (cons 'nnselect-specs + (gnus-group-get-parameter gnus-newsgroup-name + 'nnselect-specs t)))))))) + (defun gnus-summary-save-newsrc (&optional force) "Save the current number of read/marked articles in the dribble buffer. The dribble buffer will then be saved. @@ -7310,7 +7192,7 @@ If FORCE (the prefix), also save the .newsrc file(s)." (when gnus-use-cache (gnus-cache-write-active)) ;; Remove entries for this group. - (nnmail-purge-split-history (gnus-group-real-name group)) + (nnmail-purge-split-history group) ;; Make all changes in this group permanent. (unless quit-config (gnus-run-hooks 'gnus-exit-group-hook) @@ -7331,6 +7213,8 @@ If FORCE (the prefix), also save the .newsrc file(s)." (gnus-group-next-unread-group 1)) (setq group-point (point)) (gnus-article-stop-animations) + (unless leave-hidden + (gnus-configure-windows 'group 'force)) (if temporary nil ;Nothing to do. (set-buffer buf) @@ -7350,8 +7234,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (if quit-config (gnus-handle-ephemeral-exit quit-config) (goto-char group-point) - (unless leave-hidden - (gnus-configure-windows 'group 'force)) ;; If gnus-group-buffer is already displayed, make sure we also move ;; the cursor in the window that displays it. (let ((win (get-buffer-window (current-buffer) 0))) @@ -8698,7 +8580,8 @@ SCORE." When called interactively, ID is the Message-ID of the current article. If thread-only is non-nil limit the summary buffer to these articles." - (interactive (list (mail-header-id (gnus-summary-article-header)))) + (interactive (list (mail-header-id (gnus-summary-article-header)) + current-prefix-arg)) (let ((articles (gnus-articles-in-thread (gnus-id-to-thread (gnus-root-id id)))) ;;we REALLY want the whole thread---this prevents cut-threads @@ -9121,25 +9004,24 @@ Return the number of articles fetched." result)) (defun gnus-summary-refer-thread (&optional limit) - "Fetch all articles in the current thread. For backends -that know how to search for threads (currently only 'nnimap) -a non-numeric prefix arg will use nnir to search the entire -server; without a prefix arg only the current group is -searched. If the variable `gnus-refer-thread-use-nnir' is -non-nil the prefix arg has the reverse meaning. If no -backend-specific `request-thread' function is available fetch -LIMIT (the numerical prefix) old headers. If LIMIT is -non-numeric or nil fetch the number specified by the -`gnus-refer-thread-limit' variable." + "Fetch all articles in the current thread. +For backends that know how to search for threads (currently only +`nnimap') a non-numeric prefix arg will search the entire server; +without a prefix arg only the current group is searched. If the +variable `gnus-refer-thread-use-search' is non-nil the prefix arg +has the reverse meaning. If no backend-specific `request-thread' +function is available fetch LIMIT (the numerical prefix) old +headers. If LIMIT is non-numeric or nil fetch the number +specified by the `gnus-refer-thread-limit' variable." (interactive "P") (let* ((header (gnus-summary-article-header)) (id (mail-header-id header)) (gnus-inhibit-demon t) (gnus-summary-ignore-duplicates t) (gnus-read-all-available-headers t) - (gnus-refer-thread-use-nnir + (gnus-refer-thread-use-search (if (and (not (null limit)) (listp limit)) - (not gnus-refer-thread-use-nnir) gnus-refer-thread-use-nnir)) + (not gnus-refer-thread-use-search) gnus-refer-thread-use-search)) (new-headers (if (gnus-check-backend-function 'request-thread gnus-newsgroup-name) @@ -9280,9 +9162,9 @@ non-numeric or nil fetch the number specified by the (dolist (method gnus-refer-article-method) (push (if (eq 'current method) gnus-current-select-method - (if (eq 'nnir (car method)) + (if (eq 'nnselect (car method)) (list - 'nnir + 'nnselect (or (cadr method) (gnus-method-to-server gnus-current-select-method))) method)) @@ -9493,16 +9375,6 @@ The 1st element is the button named by `gnus-collect-urls-primary-text'." (push primary urls)) (delete-dups urls))) -;; cf. `ediff-truncate-string-left', to become `string-truncate-left' -;; in Emacs 28 -(defun gnus--string-truncate-left (string length) - "Truncate STRING to LENGTH, replacing initial surplus with \"...\"." - (let ((strlen (length string))) - (if (<= strlen length) - string - (setq length (max 0 (- length 3))) - (concat "..." (substring string (max 0 (- strlen 1 length))))))) - (defun gnus-shorten-url (url max) "Return an excerpt from URL not exceeding MAX characters." (if (<= (length url) max) @@ -9512,7 +9384,7 @@ The 1st element is the button named by `gnus-collect-urls-primary-text'." (rest (concat (url-filename parsed) (when-let ((target (url-target parsed))) (concat "#" target))))) - (concat host (gnus--string-truncate-left rest (- max (length host))))))) + (concat host (string-truncate-left rest (- max (length host))))))) (defun gnus-summary-browse-url (&optional external) "Scan the current article body for links, and offer to browse them. @@ -9536,10 +9408,10 @@ default." (cond ((= (length urls) 1) (car urls)) ((> (length urls) 1) - (completing-read (format "URL to browse (default %s): " - (gnus-shorten-url (car urls) 40)) - urls nil t nil nil - (car urls))))) + (completing-read + (format-prompt "URL to browse" + (gnus-shorten-url (car urls) 40)) + urls nil t nil nil (car urls))))) (if target (if external (funcall browse-url-secondary-browser-function target) @@ -10836,6 +10708,7 @@ groups." ;; We only have to update this line. (save-excursion (save-restriction + (nnheader-ms-strip-cr) (message-narrow-to-head) (let ((head (buffer-substring-no-properties (point-min) (point-max))) @@ -11664,7 +11537,7 @@ If ALL is non-nil, also mark ticked and dormant articles as read." (gnus-save-hidden-threads (let ((beg (point))) ;; We check that there are unread articles. - (when (or all (gnus-summary-find-next)) + (when (or all (gnus-summary-last-article-p) (gnus-summary-find-next)) (gnus-summary-catchup all t beg nil t))))) (gnus-summary-position-point)) @@ -11933,8 +11806,6 @@ will not be hidden." (defun gnus-summary-hide-thread () "Hide thread subtrees. -If PREDICATE is supplied, threads that satisfy this predicate -will not be hidden. Returns nil if no threads were there to be hidden." (interactive) (beginning-of-line) @@ -11955,9 +11826,9 @@ Returns nil if no threads were there to be hidden." (overlay-put ol 'invisible 'gnus-sum) (overlay-put ol 'evaporate t))) (gnus-summary-goto-subject article) + ;; We moved backward past the start point (invisible thread?) (when (> start (point)) - (message "Hiding the thread moved us backwards, aborting!") - (goto-char (point-max)))) + (goto-char starteol))) (goto-char start) nil)))) @@ -12291,7 +12162,7 @@ no matter what the properties `:decode' and `:headers' are." (interactive (gnus-interactive "P\ny")) (require 'gnus-art) (let* ((articles (gnus-summary-work-articles n)) - (result-buffer "*Shell Command Output*") + (result-buffer shell-command-buffer-name) (all-headers (not (memq sym '(nil r)))) (gnus-save-all-headers (or all-headers gnus-save-all-headers)) (raw (eq sym 'r)) @@ -12320,7 +12191,7 @@ no matter what the properties `:decode' and `:headers' are." (buffer-string)))))) (put 'gnus-summary-save-in-pipe :headers headers)) (unless (zerop (length result)) - (if (with-current-buffer (get-buffer-create result-buffer) + (if (with-current-buffer (gnus-get-buffer-create result-buffer) (erase-buffer) (insert result) (prog1 @@ -12508,7 +12379,7 @@ save those articles instead." (gnus-activate-group to-newsgroup nil nil to-method) (gnus-subscribe-group to-newsgroup)) (error "Couldn't create group %s" to-newsgroup))) - (error "No such group: %s" to-newsgroup)) + (user-error "No such group: %s" to-newsgroup)) to-newsgroup))) (defvar gnus-summary-save-parts-counter) @@ -12518,10 +12389,15 @@ save those articles instead." "Save parts matching TYPE to DIR. If REVERSE, save parts that do not match TYPE." (interactive - (list (read-string "Save parts of type: " - (or (car gnus-summary-save-parts-type-history) - gnus-summary-save-parts-default-mime) - 'gnus-summary-save-parts-type-history) + (list (completing-read "Save parts of type: " + (progn + (gnus-summary-select-article nil t) + (gnus-eval-in-buffer-window gnus-article-buffer + (delete-dups + (mapcar (lambda (h) + (mm-handle-media-type (cdr h))) + gnus-article-mime-handle-alist)))) + nil nil nil 'gnus-summary-save-parts-type-history) (setq gnus-summary-save-parts-last-directory (read-directory-name "Save to directory: " gnus-summary-save-parts-last-directory @@ -13169,10 +13045,13 @@ If ALL is a number, fetch this number of articles." (t (when (and (numberp gnus-large-newsgroup) (> len gnus-large-newsgroup)) - (let* ((cursor-in-echo-area nil) - (initial (gnus-parameter-large-newsgroup-initial - gnus-newsgroup-name)) - (input + (let ((cursor-in-echo-area nil) + (initial (gnus-parameter-large-newsgroup-initial + gnus-newsgroup-name)) + input) + (when (eq initial 'all) + (setq initial len)) + (setq input (read-string (format "How many articles from %s (%s %d): " @@ -13181,7 +13060,7 @@ If ALL is a number, fetch this number of articles." len) nil nil (and initial - (number-to-string initial))))) + (number-to-string initial)))) (unless (string-match "^[ \t]*$" input) (setq all (string-to-number input)) (if (< all len) diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index ffd26bb30f4..c913002f70b 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -897,9 +897,7 @@ articles in the topic and its subtopics." (let ((inhibit-read-only t)) (unless gnus-topic-inhibit-change-level (gnus-group-goto-group (or (car (nth 1 previous)) group)) - (when (and gnus-topic-mode - gnus-topic-alist - (not gnus-topic-inhibit-change-level)) + (when (and gnus-topic-mode gnus-topic-alist (gnus-current-topic)) ;; Remove the group from the topics. (if (and (< oldlevel gnus-level-zombie) (>= level gnus-level-zombie)) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index f255cfc74a0..ef811c65b86 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -455,9 +455,7 @@ displayed in the echo area." (> message-log-max 0) (/= (length str) 0)) (setq time (current-time)) - (with-current-buffer (if (fboundp 'messages-buffer) - (messages-buffer) - (get-buffer-create "*Messages*")) + (with-current-buffer (messages-buffer) (goto-char (point-max)) (let ((inhibit-read-only t)) (insert ,timestamp str "\n") @@ -768,7 +766,7 @@ nil. See also `gnus-bind-print-variables'." If there's no subdirectory, delete DIRECTORY as well." (when (file-directory-p directory) (let ((files (directory-files - directory t (rx (or (not ".") "...")))) + directory t directory-files-no-dot-files-regexp)) file dir) (while files (setq file (pop files)) @@ -950,7 +948,7 @@ FILENAME exists and is Babyl format." (setq rmail-default-rmail-file filename) ; 22 (setq rmail-default-file filename)) ; 23 (let ((artbuf (current-buffer)) - (tmpbuf (get-buffer-create " *Gnus-output*")) + (tmpbuf (gnus-get-buffer-create " *Gnus-output*")) ;; Babyl rmail.el defines this, mbox does not. (babyl (fboundp 'rmail-insert-rmail-file-header))) (save-excursion @@ -1015,6 +1013,12 @@ FILENAME exists and is Babyl format." (rmail-swap-buffers-maybe) (rmail-maybe-set-message-counters)) (widen) + (unless babyl + (goto-char (point-max)) + ;; Ensure we have a blank line before the next message. + (unless (bolp) + (insert "\n")) + (insert "\n")) (narrow-to-region (point-max) (point-max))) (insert-buffer-substring tmpbuf) (when msg @@ -1036,7 +1040,7 @@ FILENAME exists and is Babyl format." (require 'nnmail) (setq filename (expand-file-name filename)) (let ((artbuf (current-buffer)) - (tmpbuf (get-buffer-create " *Gnus-output*"))) + (tmpbuf (gnus-get-buffer-create " *Gnus-output*"))) (save-excursion ;; Create the file, if it doesn't exist. (when (and (not (get-file-buffer filename)) @@ -1179,7 +1183,7 @@ ARG is passed to the first function." (maphash (lambda (group active) (when active - (insert (format "%s %d %d y\n" + (insert (format "%S %d %d y\n" (if full-names group (gnus-group-real-name group)) @@ -1345,6 +1349,61 @@ forbidden in URL encoding." (setq tmp (concat tmp str)) tmp)) +(defun gnus-base64-repad (str &optional reject-newlines line-length no-check) + "Take a base 64-encoded string and return it padded correctly. +Existing padding is ignored. + +If any combination of CR and LF characters are present and +REJECT-NEWLINES is nil, remove them; otherwise raise an error. +If LINE-LENGTH is set and the string (or any line in the string +if REJECT-NEWLINES is nil) is longer than that number, raise an +error. Common line length for input characters are 76 plus CRLF +(RFC 2045 MIME), 64 plus CRLF (RFC 1421 PEM), and 1000 including +CRLF (RFC 5321 SMTP). + +If NOCHECK, don't check anything, but just repad." + ;; RFC 4648 specifies that: + ;; - three 8-bit inputs make up a 24-bit group + ;; - the 24-bit group is broken up into four 6-bit values + ;; - each 6-bit value is mapped to one character of the base 64 alphabet + ;; - if the final 24-bit quantum is filled with only 8 bits the output + ;; will be two base 64 characters followed by two "=" padding characters + ;; - if the final 24-bit quantum is filled with only 16 bits the output + ;; will be three base 64 character followed by one "=" padding character + ;; + ;; RFC 4648 section 3 considerations: + ;; - if reject-newlines is nil (default), concatenate multi-line + ;; input (3.1, 3.3) + ;; - if line-length is set, error on input exceeding the limit (3.1) + ;; - reject characters outside base encoding (3.3, also section 12) + ;; + ;; RFC 5322 section 2.2.3 consideration: + ;; Because base 64-encoded strings can appear in long header fields, remove + ;; folding whitespace while still observing the RFC 4648 decisions above. + (when no-check + (setq str (replace-regexp-in-string "[\n\r \t]+" "" str))); + (let ((splitstr (split-string str "[ \t]*[\r\n]+[ \t]?" t))) + (when (and reject-newlines (> (length splitstr) 1)) + (error "Invalid Base64 string")) + (dolist (substr splitstr) + (when (and line-length (> (length substr) line-length)) + (error "Base64 string exceeds line-length")) + (when (string-match "[^A-Za-z0-9+/=]" substr) + (error "Invalid Base64 string"))) + (let* ((str (string-join splitstr)) + (len (length str))) + (when (string-match "=" str) + (setq len (match-beginning 0))) + (concat + (substring str 0 len) + (make-string (/ + (- 24 + (pcase (mod (* len 6) 24) + (`0 24) + (n n))) + 6) + ?=))))) + (defun gnus-make-predicate (spec) "Transform SPEC into a function that can be called. SPEC is a predicate specifier that contains stuff like `or', `and', @@ -1457,7 +1516,7 @@ CHOICE is a list of the choice char and help message at IDX." (setq tchar (read-char)) (when (not (assq tchar choice)) (setq tchar nil) - (setq buf (get-buffer-create "*Gnus Help*")) + (setq buf (gnus-get-buffer-create "*Gnus Help*")) (pop-to-buffer buf) (fundamental-mode) (buffer-disable-undo) @@ -1601,10 +1660,10 @@ empty directories from OLD-PATH." (file-truename (concat old-dir ".."))))))))) -(defun gnus-set-file-modes (filename mode) +(defun gnus-set-file-modes (filename mode &optional flag) "Wrapper for set-file-modes." (ignore-errors - (set-file-modes filename mode))) + (set-file-modes filename mode flag))) (defun gnus-rescale-image (image size) "Rescale IMAGE to SIZE if possible. @@ -1654,6 +1713,7 @@ The first found will be returned if a file has hard or symbolic links." "To each element of LIST apply PREDICATE. Return nil if LIST is no list or is empty or some test returns nil; otherwise, return t." + (declare (obsolete nil "28.1")) (when (and list (listp list)) (let ((result (mapcar predicate list))) (not (memq nil result))))) diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el index 5902f2b37a7..70aeac00d7f 100644 --- a/lisp/gnus/gnus-uu.el +++ b/lisp/gnus/gnus-uu.el @@ -1674,7 +1674,7 @@ Gnus might fail to display all of it.") did-unpack)) (defun gnus-uu-dir-files (dir) - (let ((dirs (directory-files dir t (rx (or (not ".") "...")))) + (let ((dirs (directory-files dir t directory-files-no-dot-files-regexp)) files file) (while dirs (if (file-directory-p (setq file (car dirs))) @@ -1781,8 +1781,8 @@ Gnus might fail to display all of it.") gnus-uu-tmp-dir))) (setq gnus-uu-work-dir - (make-temp-file (concat gnus-uu-tmp-dir "gnus") 'dir)) - (gnus-set-file-modes gnus-uu-work-dir 448) + (with-file-modes #o700 + (make-temp-file (concat gnus-uu-tmp-dir "gnus") 'dir))) (setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir)) (push (cons gnus-newsgroup-name gnus-uu-work-dir) gnus-uu-tmp-alist)))) diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el index 36b28350362..baa3146e64e 100644 --- a/lisp/gnus/gnus-win.el +++ b/lisp/gnus/gnus-win.el @@ -142,7 +142,7 @@ used to display Gnus windows." (pipe (vertical 1.0 (summary 0.25 point) - ("*Shell Command Output*" 1.0))) + (shell-command-buffer-name 1.0))) (bug (vertical 1.0 (if gnus-bug-create-help-buffer '("*Gnus Help Bug*" 0.5)) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 6df26b4af8c..c1cfddc87b3 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -292,6 +292,10 @@ is restarted, and sometimes reloaded." :link '(custom-manual "(gnus)Exiting Gnus") :group 'gnus) +(defgroup gnus-dbus nil + "D-Bus integration for Gnus." + :group 'gnus) + (defconst gnus-version-number "5.13" "Version number for this version of Gnus.") @@ -660,7 +664,7 @@ be used directly.") (defun gnus-add-buffer () "Add the current buffer to the list of Gnus buffers." (gnus-prune-buffers) - (push (current-buffer) gnus-buffers)) + (cl-pushnew (current-buffer) gnus-buffers)) (defmacro gnus-kill-buffer (buffer) "Kill BUFFER and remove from the list of Gnus buffers." @@ -849,12 +853,6 @@ be used directly.") (cons (car list) (list :type type :data data))) list))) -(let ((command (format "%s" this-command))) - (when (string-match "gnus" command) - (if (eq 'gnus-other-frame this-command) - (gnus-get-buffer-create gnus-group-buffer) - (gnus-splash)))) - ;;; Do the rest. (require 'gnus-util) @@ -1029,8 +1027,7 @@ Check the NNTPSERVER environment variable and the ;; `M-x customize-variable RET gnus-select-method RET' should work without ;; starting or even loading Gnus. -;;;###autoload(when (fboundp 'custom-autoload) -;;;###autoload (custom-autoload 'gnus-select-method "gnus")) +;;;###autoload(custom-autoload 'gnus-select-method "gnus") (defcustom gnus-select-method (list 'nntp (or (gnus-getenv-nntpserver) @@ -1591,7 +1588,7 @@ posting an article." "Alist of group regexps and its initial input of the number of articles." :variable-group gnus-group-parameter :parameter-type '(choice :tag "Initial Input for Large Newsgroup" - (const :tag "All" nil) + (const :tag "All" 'all) (integer)) :parameter-document "\ @@ -1610,7 +1607,7 @@ total number of articles in the group.") :variable-default (mapcar (lambda (g) (list g t)) '("delayed$" "drafts$" "queue$" "INBOX$" - "^nnmairix:" "^nnir:" "archive")) + "^nnmairix:" "^nnselect:" "archive")) :variable-document "Groups in which the registry should be turned off." :variable-group gnus-registry @@ -2226,8 +2223,8 @@ Disabling the agent may result in noticeable loss of performance." :group 'gnus-start :type '(choice (function-item gnus) (function-item gnus-no-server) - (function-item gnus-slave) - (function-item gnus-slave-no-server))) + (function-item gnus-child) + (function-item gnus-child-no-server))) (declare-function gnus-group-get-new-news "gnus-group") @@ -2238,8 +2235,8 @@ Disabling the agent may result in noticeable loss of performance." :type '(choice (function-item gnus) (function-item gnus-group-get-new-news) (function-item gnus-no-server) - (function-item gnus-slave) - (function-item gnus-slave-no-server))) + (function-item gnus-child) + (function-item gnus-child-no-server))) (defcustom gnus-other-frame-parameters nil "Frame parameters used by `gnus-other-frame' to create a Gnus frame." @@ -2288,6 +2285,14 @@ a string, be sure to use a valid format, see RFC 2616." (gnus-message 1 "Edit your init file to make this change permanent.") (sit-for 2))) +(defcustom gnus-agent-eagerly-store-articles t + "If non-nil, cache articles eagerly. + +When using the Gnus Agent and reading an agentized newsgroup, +automatically cache the article in the agent cache." + :type 'boolean + :version "28.1") + ;;; Internal variables @@ -2417,8 +2422,8 @@ such as a mark that says whether an article is stored in the cache (defvar gnus-article-buffer "*Article*") (defvar gnus-server-buffer "*Server*") -(defvar gnus-slave nil - "Whether this Gnus is a slave or not.") +(defvar gnus-child nil + "Whether this Gnus is a child or not.") (defvar gnus-batch-mode nil "Whether this Gnus is running in batch mode or not.") @@ -2708,6 +2713,11 @@ with some simple extensions. %k Pretty-printed version of the above (string) For example, \"1.2k\" or \"0.4M\". %L Number of lines in the article (integer) +%Z RSV of the article; nil if not in an nnselect group (integer) +%G Originating group name for the article; nil if not + in an nnselect group (string) +%g Short from of the originating group name for the article; + nil if not in an nnselect group (string) %I Indentation based on thread level (a string of spaces) %B A complex trn-style thread tree (string) @@ -3156,7 +3166,10 @@ that that variable is buffer-local to the summary buffers." (defun gnus-kill-ephemeral-group (group) "Remove ephemeral GROUP from relevant structures." - (remhash group gnus-newsrc-hashtb)) + (remhash group gnus-newsrc-hashtb) + (setq gnus-newsrc-alist + (delq (assoc group gnus-newsrc-alist) + gnus-newsrc-alist))) (defun gnus-simplify-mode-line () "Make mode lines a bit simpler." @@ -3623,11 +3636,12 @@ If you call this function inside a loop, consider using the faster (defun gnus-group-get-parameter (group &optional symbol allow-list) "Return the group parameters for GROUP. -If SYMBOL, return the value of that symbol in the group parameters. -If ALLOW-LIST, also allow list as a result. -Most functions should use `gnus-group-find-parameter', which -also examines the topic parameters." - (let ((params (gnus-info-params (gnus-get-info group)))) +If SYMBOL, return the value of that symbol in the group +parameters. If ALLOW-LIST, also allow list as a result. Most +functions should use `gnus-group-find-parameter', which also +examines the topic parameters. GROUP can also be an info structure." + (let ((params (gnus-info-params (if (listp group) group + (gnus-get-info group))))) (if symbol (gnus-group-parameter-value params symbol allow-list) params))) @@ -4034,13 +4048,20 @@ Allow completion over sensible values." ;;; User-level commands. ;;;###autoload +(defun gnus-child-no-server (&optional arg) + "Read network news as a child, without connecting to the local server." + (interactive "P") + (gnus-no-server arg t)) + +;;;###autoload (defun gnus-slave-no-server (&optional arg) - "Read network news as a slave, without connecting to the local server." + "Read network news as a child, without connecting to the local server." (interactive "P") (gnus-no-server arg t)) +(make-obsolete 'gnus-slave-no-server 'gnus-child-no-server "28.1") ;;;###autoload -(defun gnus-no-server (&optional arg slave) +(defun gnus-no-server (&optional arg child) "Read network news. If ARG is a positive number, Gnus will use that as the startup level. If ARG is nil, Gnus will be started at level 2. If ARG is non-nil @@ -4049,13 +4070,20 @@ an NNTP server to use. As opposed to `gnus', this command will not connect to the local server." (interactive "P") - (gnus-no-server-1 arg slave)) + (gnus-no-server-1 arg child)) + +;;;###autoload +(defun gnus-child (&optional arg) + "Read news as a child." + (interactive "P") + (gnus arg nil 'child)) ;;;###autoload (defun gnus-slave (&optional arg) - "Read news as a slave." + "Read news as a child." (interactive "P") - (gnus arg nil 'slave)) + (gnus arg nil 'child)) +(make-obsolete 'gnus-slave 'gnus-child "28.1") (defun gnus-delete-gnus-frame () "Delete gnus frame unless it is the only one. @@ -4116,7 +4144,7 @@ current display is used." (add-hook 'gnus-suspend-gnus-hook #'gnus-delete-gnus-frame))))) ;;;###autoload -(defun gnus (&optional arg dont-connect slave) +(defun gnus (&optional arg dont-connect child) "Read network news. If ARG is non-nil and a positive number, Gnus will use that as the startup level. If ARG is non-nil and not a positive number, Gnus will @@ -4130,7 +4158,7 @@ prompt the user for the name of an NNTP server to use." (message "You should byte-compile Gnus") (sit-for 2)) (let ((gnus-action-message-log (list nil))) - (gnus-1 arg dont-connect slave) + (gnus-1 arg dont-connect child) (gnus-final-warning))) (declare-function debbugs-gnu "ext:debbugs-gnu" diff --git a/lisp/gnus/gssapi.el b/lisp/gnus/gssapi.el index 218a1542e3a..485d58ad94e 100644 --- a/lisp/gnus/gssapi.el +++ b/lisp/gnus/gssapi.el @@ -25,8 +25,6 @@ ;;; Code: -(require 'format-spec) - (defcustom gssapi-program (list (concat "gsasl %s %p " "--mechanism GSSAPI " @@ -53,12 +51,9 @@ tried until a successful connection is made." (coding-system-for-write 'binary) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?p (number-to-string port) - ?l user)))) + (format-spec cmd `((?s . ,server) + (?p . ,(number-to-string port)) + (?l . ,user))))) response) (when process (while (and (memq (process-status process) '(open run)) diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index 52343d4fa37..43180726c45 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -24,7 +24,6 @@ ;;; Code: -(require 'format-spec) (eval-when-compile (require 'cl-lib) (require 'imap)) @@ -695,7 +694,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) mail-source-movemail-program nil errors nil from to))))) (when (file-exists-p to) - (set-file-modes to mail-source-default-file-modes)) + (set-file-modes to mail-source-default-file-modes 'nofollow)) (if (and (or (not (buffer-modified-p errors)) (zerop (buffer-size errors))) (and (numberp result) @@ -740,9 +739,11 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (when delay (sleep-for delay))) +(declare-function gnus-get-buffer-create "gnus" (name)) (defun mail-source-call-script (script) + (require 'gnus) (let ((background nil) - (stderr (get-buffer-create " *mail-source-stderr*")) + (stderr (gnus-get-buffer-create " *mail-source-stderr*")) result) (when (string-match "& *$" script) (setq script (substring script 0 (match-beginning 0)) @@ -767,14 +768,14 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) "Fetcher for single-file sources." (mail-source-bind (file source) (mail-source-run-script - prescript (format-spec-make ?t mail-source-crash-box) + prescript `((?t . ,mail-source-crash-box)) prescript-delay) (let ((mail-source-string (format "file:%s" path))) (if (mail-source-movemail path mail-source-crash-box) (prog1 (mail-source-callback callback path) (mail-source-run-script - postscript (format-spec-make ?t mail-source-crash-box)) + postscript `((?t . ,mail-source-crash-box))) (mail-source-delete-crash-box)) 0)))) @@ -782,7 +783,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) "Fetcher for directory sources." (mail-source-bind (directory source) (mail-source-run-script - prescript (format-spec-make ?t path) prescript-delay) + prescript `((?t . ,path)) prescript-delay) (let ((found 0) (mail-source-string (format "directory:%s" path))) (dolist (file (directory-files @@ -791,7 +792,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (funcall predicate file) (mail-source-movemail file mail-source-crash-box)) (cl-incf found (mail-source-callback callback file)) - (mail-source-run-script postscript (format-spec-make ?t path)) + (mail-source-run-script postscript `((?t . ,path))) (mail-source-delete-crash-box))) found))) @@ -801,8 +802,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) ;; fixme: deal with stream type in format specs (mail-source-run-script prescript - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user)) prescript-delay) (let ((from (format "%s:%s:%s" server user port)) (mail-source-string (format "pop:%s@%s" user server)) @@ -823,8 +824,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (mail-source-fetch-with-program (format-spec program - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user)))) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user))))) (function (funcall function mail-source-crash-box)) ;; The default is to use pop3.el. @@ -861,8 +862,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (setq mail-source-new-mail-available nil)) (mail-source-run-script postscript - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user)) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user))) (mail-source-delete-crash-box))) ;; We nix out the password in case the error ;; was because of a wrong password being given. @@ -1075,8 +1076,9 @@ This only works when `display-time' is enabled." "Fetcher for imap sources." (mail-source-bind (imap source) (mail-source-run-script - prescript (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user) + prescript + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user)) prescript-delay) (let ((from (format "%s:%s:%s" server user port)) (found 0) @@ -1141,8 +1143,8 @@ This only works when `display-time' is enabled." (kill-buffer buf) (mail-source-run-script postscript - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user)) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user))) found))) (provide 'mail-source) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 6c425b0ea16..0782778fd43 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -42,13 +42,12 @@ (require 'mail-parse) (require 'mml) (require 'rfc822) -(require 'format-spec) (require 'dired) (require 'mm-util) (require 'rfc2047) (require 'puny) -(require 'rmc) ; read-multiple-choice -(eval-when-compile (require 'subr-x)) ; when-let* +(require 'rmc) ; read-multiple-choice +(eval-when-compile (require 'subr-x)) (autoload 'mailclient-send-it "mailclient") @@ -215,9 +214,9 @@ Also see `message-required-news-headers' and :link '(custom-manual "(message)Message Headers") :type '(repeat sexp)) -(defcustom message-draft-headers '(References From Date) +(defcustom message-draft-headers '(References From) "Headers to be generated when saving a draft message." - :version "22.1" + :version "28.1" :group 'message-news :group 'message-headers :link '(custom-manual "(message)Message Headers") @@ -304,6 +303,13 @@ any confusion." :link '(custom-manual "(message)Message Headers") :type 'regexp) +(defcustom message-screenshot-command '("import" "png:-") + "Command to take a screenshot. +The command should insert a PNG in the current buffer." + :group 'message-various + :type '(repeat string) + :version "28.1") + ;;; Start of variables adopted from `message-utils.el'. (defcustom message-subject-trailing-was-query t @@ -322,7 +328,7 @@ used." :group 'message-various) (defcustom message-subject-trailing-was-ask-regexp - "[ \t]*\\([[(]+[Ww][Aa][Ss]:?[ \t]*.*[])]+\\)" + "[ \t]*\\([[(]+[Ww][Aa][Ss].*[])]+\\)" "Regexp matching \"(was: <old subject>)\" in the subject line. The function `message-strip-subject-trailing-was' uses this regexp if @@ -337,7 +343,7 @@ It is okay to create some false positives here, as the user is asked." :type 'regexp) (defcustom message-subject-trailing-was-regexp - "[ \t]*\\((*[Ww][Aa][Ss]:[ \t]*.*)\\)" + "[ \t]*\\((*[Ww][Aa][Ss]:.*)\\)" "Regexp matching \"(was: <old subject>)\" in the subject line. If `message-subject-trailing-was-query' is set to t, the subject is @@ -440,8 +446,8 @@ whitespace)." (defcustom message-elide-ellipsis "\n[...]\n\n" "The string which is inserted for elided text. -This is a format-spec string, and you can use %l to say how many -lines were removed, and %c to say how many characters were +This is a `format-spec' string, and you can use %l to say how +many lines were removed, and %c to say how many characters were removed." :type 'string :link '(custom-manual "(message)Various Commands") @@ -848,7 +854,8 @@ symbol `never', the posting is not allowed. If it is the symbol ;; differently (bug#36937). nil "Non-nil means don't add \"-f username\" to the sendmail command line. -Doing so would be even more evil than leaving it out." +See `feedmail-sendmail-f-doesnt-sell-me-out' for an explanation +of what the \"-f\" parameter does." :group 'message-sending :link '(custom-manual "(message)Mail Variables") :type 'boolean) @@ -1099,7 +1106,8 @@ point and mark around the citation text as modified." If nil, don't insert a signature. If t, insert `message-signature-file'. If a function or form, insert its result. -See `mail-signature' for the recommended format of a signature." +See `mail-signature' for the recommended format of a signature. +Also see `message-signature-insert-empty-line'." :version "23.2" :type '(choice string (const :tag "None" nil) @@ -1986,6 +1994,7 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (autoload 'gnus-delay-article "gnus-delay") (autoload 'gnus-extract-address-components "gnus-util") (autoload 'gnus-find-method-for-group "gnus") +(autoload 'gnus-get-buffer-create "gnus") (autoload 'gnus-group-name-charset "gnus-group") (autoload 'gnus-group-name-decode "gnus-group") (autoload 'gnus-groups-from-server "gnus") @@ -2730,6 +2739,65 @@ systematically send encrypted emails when possible." (when (message-all-epg-keys-available-p) (mml-secure-message-sign-encrypt))) +(defcustom message-openpgp-header nil + "Specification for the \"OpenPGP\" header of outgoing messages. + +The value must be a list of three elements, all strings: +- Key ID, in hexadecimal form; +- Key URL or ASCII armoured key; and +- Protection preference, one of: \"unprotected\", \"sign\", + \"encrypt\" or \"signencrypt\". + +Each of the elements may be nil, in which case its part in the +OpenPGP header will be left out. If all the values are nil, +or `message-openpgp-header' is itself nil, the OpenPGP header +will not be inserted." + :type '(choice + (const :tag "Don't add OpenPGP header" nil) + (list :tag "Use OpenPGP header" + (choice (string :tag "ID") + (const :tag "No ID" nil)) + (choice (string :tag "Key") + (const :tag "No Key" nil)) + (choice (other :tag "None" nil) + (const :tag "Unprotected" "unprotected") + (const :tag "Sign" "sign") + (const :tag "Encrypt" "encrypt") + (const :tag "Sign and Encrypt" "signencrypt")))) + :version "28.1") + +(defun message-add-openpgp-header () + "Add OpenPGP header to point to public key. + +Header will be constructed as specified in `message-openpgp-header'. + +Consider adding this function to `message-header-setup-hook'" + ;; See https://tools.ietf.org/html/draft-josefsson-openpgp-mailnews-header + (when (and message-openpgp-header + (or (nth 0 message-openpgp-header) + (nth 1 message-openpgp-header) + (nth 2 message-openpgp-header))) + (message-add-header + (with-temp-buffer + (insert "OpenPGP: ") + ;; add ID + (let (need-sep) + (when (nth 0 message-openpgp-header) + (insert "id=" (nth 0 message-openpgp-header)) + (setq need-sep t)) + ;; add URL + (when (nth 1 message-openpgp-header) + (when need-sep (insert "; ")) + (insert "url=\"" (nth 1 message-openpgp-header) "\"") + (setq need-sep t)) + ;; add preference + (when (nth 2 message-openpgp-header) + (when need-sep (insert "; ")) + (insert "preference=" (nth 2 message-openpgp-header)))) + ;; insert header + (buffer-string))) + (message-sort-headers))) + ;;; @@ -2810,6 +2878,7 @@ systematically send encrypted emails when possible." (define-key message-mode-map [remap split-line] 'message-split-line) (define-key message-mode-map "\C-c\C-a" 'mml-attach-file) + (define-key message-mode-map "\C-c\C-p" 'message-insert-screenshot) (define-key message-mode-map "\C-a" 'message-beginning-of-line) (define-key message-mode-map "\t" 'message-tab) @@ -2839,6 +2908,8 @@ systematically send encrypted emails when possible." :active (message-mark-active-p) :help "Mark region with enclosing tags"] ["Insert File Marked..." message-mark-insert-file :help "Insert file at point marked with enclosing tags"] + ["Attach File..." mml-attach-file t] + ["Insert Screenshot" message-insert-screenshot t] "----" ["Send Message" message-send-and-exit :help "Send this message"] ["Postpone Message" message-dont-send @@ -3464,8 +3535,8 @@ Prefix arg means justify as well." (equal quoted (match-string 0))) (goto-char (match-end 0)) (looking-at "[ \t]*") - (if (> (length leading-space) (length (match-string 0))) - (setq leading-space (match-string 0))) + (when (< (length leading-space) (length (match-string 0))) + (setq leading-space (match-string 0))) (forward-line 1)) (setq end (point)) (goto-char beg) @@ -3542,7 +3613,14 @@ Message buffers and is not meant to be called directly." (do-auto-fill)))) (defun message-insert-signature (&optional force) - "Insert a signature. See documentation for variable `message-signature'." + "Insert a signature at the end of the buffer. + +See the documentation for the `message-signature' variable for +more information. + +If FORCE is 0 (or when called interactively), the global values +of the signature variables will be consulted if the local ones +are null." (interactive (list 0)) (let ((message-signature message-signature) (message-signature-file message-signature-file)) @@ -3976,7 +4054,6 @@ This function uses `mail-citation-hook' if that is non-nil." "Cite function in the standard Message manner." (message-cite-original-1 nil)) -(autoload 'format-spec "format-spec") (autoload 'gnus-date-get-time "gnus-util") (defun message-insert-formatted-citation-line (&optional from date tz) @@ -4001,20 +4078,18 @@ See `message-citation-line-format'." (when (or message-reply-headers (and from date)) (unless from (setq from (mail-header-from message-reply-headers))) - (let* ((data (condition-case () - (funcall (if (boundp 'gnus-extract-address-components) - gnus-extract-address-components - 'mail-extract-address-components) - from) - (error nil))) + (let* ((data (ignore-errors + (funcall (or (bound-and-true-p + gnus-extract-address-components) + #'mail-extract-address-components) + from))) (name (car data)) (fname name) (lname name) - (net (car (cdr data))) - (name-or-net (or (car data) - (car (cdr data)) from)) + (net (cadr data)) + (name-or-net (or name net from)) (time - (when (string-match "%[^fnNFL]" message-citation-line-format) + (when (string-match-p "%[^FLNfn]" message-citation-line-format) (cond ((numberp (car-safe date)) date) ;; backward compatibility (date (gnus-date-get-time date)) (t @@ -4023,68 +4098,53 @@ See `message-citation-line-format'." (tz (or tz (when (stringp date) (nth 8 (parse-time-string date))))) - (flist - (let ((i ?A) lst) - (when (stringp name) - ;; Guess first name and last name: - (let* ((names (delq - nil - (mapcar - (lambda (x) - (if (string-match "\\`\\(\\w\\|[-.]\\)+\\'" - x) - x - nil)) - (split-string name "[ \t]+")))) - (count (length names))) - (cond ((= count 1) - (setq fname (car names) - lname "")) - ((or (= count 2) (= count 3)) - (setq fname (car names) - lname (mapconcat 'identity (cdr names) " "))) - ((> count 3) - (setq fname (mapconcat 'identity - (butlast names (- count 2)) - " ") - lname (mapconcat 'identity - (nthcdr 2 names) - " ")))) - (when (string-match "\\(.*\\),\\'" fname) - (let ((newlname (match-string 1 fname))) - (setq fname lname lname newlname))))) - ;; The following letters are not used in `format-time-string': - (push ?E lst) (push "<E>" lst) - (push ?F lst) (push (or fname name-or-net) lst) - ;; We might want to use "" instead of "<X>" later. - (push ?J lst) (push "<J>" lst) - (push ?K lst) (push "<K>" lst) - (push ?L lst) (push lname lst) - (push ?N lst) (push name-or-net lst) - (push ?O lst) (push "<O>" lst) - (push ?P lst) (push "<P>" lst) - (push ?Q lst) (push "<Q>" lst) - (push ?f lst) (push from lst) - (push ?i lst) (push "<i>" lst) - (push ?n lst) (push net lst) - (push ?o lst) (push "<o>" lst) - (push ?q lst) (push "<q>" lst) - (push ?t lst) (push "<t>" lst) - (push ?v lst) (push "<v>" lst) - ;; Delegate the rest to `format-time-string': - (while (<= i ?z) - (when (and (not (memq i lst)) - ;; Skip (Z,a) - (or (<= i ?Z) - (>= i ?a))) - (push i lst) - (push (condition-case nil - (format-time-string (format "%%%c" i) time tz) - (error (format ">%c<" i))) - lst)) - (setq i (1+ i))) - (reverse lst))) - (spec (apply 'format-spec-make flist))) + spec) + (when (stringp name) + ;; Guess first name and last name: + (let* ((names (seq-filter + (lambda (s) + (string-match-p (rx bos (+ (in word ?. ?-)) eos) s)) + (split-string name "[ \t]+"))) + (count (length names))) + (cond ((= count 1) + (setq fname (car names) + lname "")) + ((or (= count 2) (= count 3)) + (setq fname (car names) + lname (string-join (cdr names) " "))) + ((> count 3) + (setq fname (string-join (butlast names (- count 2)) + " ") + lname (string-join (nthcdr 2 names) " ")))) + (when (string-match "\\(.*\\),\\'" fname) + (let ((newlname (match-string 1 fname))) + (setq fname lname lname newlname))))) + ;; The following letters are not used in `format-time-string': + (push (cons ?E "<E>") spec) + (push (cons ?F (or fname name-or-net)) spec) + ;; We might want to use "" instead of "<X>" later. + (push (cons ?J "<J>") spec) + (push (cons ?K "<K>") spec) + (push (cons ?L lname) spec) + (push (cons ?N name-or-net) spec) + (push (cons ?O "<O>") spec) + (push (cons ?P "<P>") spec) + (push (cons ?Q "<Q>") spec) + (push (cons ?f from) spec) + (push (cons ?i "<i>") spec) + (push (cons ?n net) spec) + (push (cons ?o "<o>") spec) + (push (cons ?q "<q>") spec) + (push (cons ?t "<t>") spec) + (push (cons ?v "<v>") spec) + ;; Delegate the rest to `format-time-string': + (dolist (c (nconc (number-sequence ?A ?Z) + (number-sequence ?a ?z))) + (unless (assq c spec) + (push (cons c (condition-case nil + (format-time-string (format "%%%c" c) time tz) + (error (format ">%c<" c)))) + spec))) (insert (format-spec message-citation-line-format spec))) (newline))) @@ -4376,7 +4436,7 @@ conformance." (error "Invisible text found and made visible"))))) (message-check 'illegible-text (let (char found choice nul-chars) - (message-goto-body) + (goto-char (point-min)) (setq nul-chars (save-excursion (search-forward "\000" nil t))) (while (progn @@ -4412,11 +4472,12 @@ conformance." ,(format "Replace non-printable characters with \"%s\" and send" message-replacement-char)) + (?u "url-encode" "Use URL %hex encoding") (?s "send" "Send as is without removing anything") (?e "edit" "Continue editing"))))) (if (eq choice ?e) (error "Non-printable characters")) - (message-goto-body) + (goto-char (point-min)) (skip-chars-forward mm-7bit-chars) (while (not (eobp)) (when (let ((char (char-after))) @@ -4433,11 +4494,17 @@ conformance." control-1)) (not (get-text-property (point) 'untranslated-utf-8))))) - (if (eq choice ?i) - (message-kill-all-overlays) + (cond + ((eq choice ?i) + (message-kill-all-overlays)) + ((eq choice ?u) + (let ((char (get-byte (point)))) + (delete-char 1) + (insert (format "%%%x" char)))) + (t (delete-char 1) (when (eq choice ?r) - (insert message-replacement-char)))) + (insert message-replacement-char))))) (forward-char) (skip-chars-forward mm-7bit-chars))))) (message-check 'bogus-recipient @@ -4507,7 +4574,8 @@ This function could be useful in `message-setup-hook'." (custom-add-option 'message-setup-hook 'message-check-recipients) (defun message-add-action (action &rest types) - "Add ACTION to be performed when doing an exit of type TYPES." + "Add ACTION to be performed when doing an exit of type TYPES. +Valid types are `send', `return', `exit', `kill' and `postpone'." (while types (add-to-list (intern (format "message-%s-actions" (pop types))) action))) @@ -4757,7 +4825,7 @@ If you always want Gnus to send messages in one piece, set message-courtesy-message))) ;; If this was set, `sendmail-program' takes care of encoding. (unless message-inhibit-body-encoding - ;; Let's make sure we encoded all the body. + ;; Let's make sure we encoded everything in the buffer. (cl-assert (save-excursion (goto-char (point-min)) (not (re-search-forward "[^\000-\377]" nil t))))) @@ -4782,15 +4850,16 @@ If you always want Gnus to send messages in one piece, set Each line should be no more than 79 characters long." (goto-char (point-min)) (while (not (eobp)) - (when (and (looking-at "[^:]+:") - (> (- (line-end-position) (point)) 79)) - (mail-header-fold-field)) - (forward-line 1))) + (if (and (looking-at "[^:]+:") + (> (- (line-end-position) (point)) 79)) + (goto-char (mail-header-fold-field)) + (forward-line 1)))) (defvar sendmail-program) (defvar smtpmail-smtp-server) (defvar smtpmail-smtp-service) (defvar smtpmail-smtp-user) +(defvar smtpmail-stream-type) (defun message-multi-smtp-send-mail () "Send the current buffer to `message-send-mail-function'. @@ -4809,6 +4878,11 @@ that instead." (let* ((smtpmail-smtp-server (nth 1 method)) (service (nth 2 method)) (port (string-to-number service)) + ;; If we're talking to the TLS SMTP port, then force a + ;; TLS connection. + (smtpmail-stream-type (if (= port 465) + 'tls + smtpmail-stream-type)) (smtpmail-smtp-service (if (> port 0) port service)) (smtpmail-smtp-user (or (nth 3 method) smtpmail-smtp-user))) (message-smtpmail-send-it))) @@ -5591,7 +5665,7 @@ The result is a fixnum." (mail-file-babyl-p filename)) ;; gnus-output-to-mail does the wrong thing with live, mbox ;; Rmail buffers in Emacs 23. - ;; http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=597255 + ;; https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=597255 (let ((buff (find-buffer-visiting filename))) (and buff (with-current-buffer buff (eq major-mode 'rmail-mode))))) @@ -6443,7 +6517,7 @@ When called without a prefix argument, header value spanning multiple lines is treated as a single line. Otherwise, even if N is 1, when point is on a continuation header line, it will be moved to the beginning " - (interactive "p") + (interactive "^p") (cond ;; Go to beginning of header or beginning of line. ((and message-beginning-of-line (message-point-in-header-p)) @@ -7006,15 +7080,28 @@ want to get rid of this query permanently."))) ;; Build the header alist. Allow the user to be asked whether ;; or not to reply to all recipients in a wide reply. - (setq follow-to (list (cons 'To (cdr (pop recipients))))) - (when (and recipients - (or (not message-wide-reply-confirm-recipients) - (y-or-n-p "Reply to all recipients? "))) - (setq recipients (mapconcat - (lambda (addr) (cdr addr)) recipients ", ")) - (if (string-match "^ +" recipients) - (setq recipients (substring recipients (match-end 0)))) - (push (cons 'Cc recipients) follow-to))) + (when (or (< (length recipients) 2) + (not message-wide-reply-confirm-recipients) + (y-or-n-p "Reply to all recipients? ")) + (if never-mct + ;; The author has requested never to get a (wide) + ;; response, so put everybody else into the To header. + ;; This avoids looking as if we're To-in somebody else in + ;; specific, and just Cc-in the rest. + (setq follow-to (list + (cons 'To + (mapconcat + (lambda (addr) + (cdr addr)) recipients ", ")))) + ;; Put the first recipient in the To header. + (setq follow-to (list (cons 'To (cdr (pop recipients))))) + ;; Put the rest of the recipients in Cc. + (when recipients + (setq recipients (mapconcat + (lambda (addr) (cdr addr)) recipients ", ")) + (if (string-match "^ +" recipients) + (setq recipients (substring recipients (match-end 0)))) + (push (cons 'Cc recipients) follow-to))))) follow-to)) (defun message-prune-recipients (recipients) @@ -7310,7 +7397,7 @@ If ARG, allow editing of the cancellation message." ;; Make control message. (if arg (message-news) - (setq buf (set-buffer (get-buffer-create " *message cancel*")))) + (setq buf (set-buffer (gnus-get-buffer-create " *message cancel*")))) (erase-buffer) (insert "Newsgroups: " newsgroups "\n" "From: " from "\n" @@ -7731,7 +7818,7 @@ is for the internal use." gcc beg) ;; We first set up a normal mail buffer. (unless (message-mail-user-agent) - (set-buffer (get-buffer-create " *message resend*")) + (set-buffer (gnus-get-buffer-create " *message resend*")) (let ((inhibit-read-only t)) (erase-buffer))) (let ((message-this-is-mail t) @@ -7983,7 +8070,7 @@ See `gmm-tool-bar-from-list' for details on the format of the list." (defcustom message-tool-bar-retro '(;; Old Emacs 21 icon for consistency. - (message-send-and-exit "gnus/mail-send") + (message-send-and-exit "mail/send") (message-kill-buffer "close") (message-dont-send "cancel") (mml-attach-file "attach" mml-mode-map) @@ -8510,7 +8597,7 @@ Meant for use on `completion-at-point-functions'." ;; FIXME: What is the most common term (circular letter, form letter, serial ;; letter, standard letter) for such kind of letter? See also -;; <http://en.wikipedia.org/wiki/Form_letter> +;; <https://en.wikipedia.org/wiki/Form_letter> ;; FIXME: Maybe extent message-mode's font-lock support to recognize ;; `message-form-letter-separator', i.e. highlight each message like a single @@ -8670,8 +8757,112 @@ Used in `message-simplify-recipients'." (* 0.5 (- (nth 3 edges) (nth 1 edges))))) string))))))) +(defun message-insert-screenshot (delay) + "Take a screenshot and insert in the current buffer. +DELAY (the numeric prefix) says how many seconds to wait before +starting the screenshotting process. + +The `message-screenshot-command' variable says what command is +used to take the screenshot." + (interactive "p") + (unless (executable-find (car message-screenshot-command)) + (error "Can't find %s to take the screenshot" + (car message-screenshot-command))) + (cl-decf delay) + (unless (zerop delay) + (dotimes (i delay) + (message "Sleeping %d second%s..." + (- delay i) + (if (= (- delay i) 1) + "" + "s")) + (sleep-for 1))) + (message "Take screenshot") + (let ((image + (with-temp-buffer + (set-buffer-multibyte nil) + (apply #'call-process + (car message-screenshot-command) nil (current-buffer) nil + (cdr message-screenshot-command)) + (buffer-string)))) + (set-mark (point)) + (insert-image + (create-image image 'png t + :max-width (truncate (* (frame-pixel-width) 0.8)) + :max-height (truncate (* (frame-pixel-height) 0.8)) + :scale 1) + (format "<#part type=\"image/png\" disposition=inline data-encoding=base64 raw=t>\n%s\n<#/part>" + ;; Get a base64 version of the image -- this avoids later + ;; complications if we're auto-saving the buffer and + ;; restoring from a file. + (with-temp-buffer + (set-buffer-multibyte nil) + (insert image) + (base64-encode-region (point-min) (point-max) t) + (buffer-string)))) + (insert "\n\n") + (message ""))) + +(declare-function gnus-url-unhex-string "gnus-util") + +(defun message-parse-mailto-url (url) + "Parse a mailto: url." + (setq url (replace-regexp-in-string "\n" " " url)) + (when (string-match "mailto:/*\\(.*\\)" url) + (setq url (substring url (match-beginning 1) nil))) + (setq url (if (string-match "^\\?" url) + (substring url 1) + (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url) + (concat "to=" (match-string 1 url) "&" + (match-string 2 url)) + (concat "to=" url)))) + (let (retval pairs cur key val) + (setq pairs (split-string url "&")) + (while pairs + (setq cur (car pairs) + pairs (cdr pairs)) + (if (not (string-match "=" cur)) + nil ; Grace + (setq key (downcase (gnus-url-unhex-string + (substring cur 0 (match-beginning 0)))) + val (gnus-url-unhex-string (substring cur (match-end 0) nil) t)) + (setq cur (assoc key retval)) + (if cur + (setcdr cur (cons val (cdr cur))) + (setq retval (cons (list key val) retval))))) + retval)) + +;;;###autoload +(defun message-mailto () + "Command to parse command line mailto: links. +This is meant to be used for MIME handlers: Setting the handler +for \"x-scheme-handler/mailto;\" to \"emacs -f message-mailto %u\" +will then start up Emacs ready to compose mail." + (interactive) + ;; <a href="mailto:someone@example.com?subject=This%20is%20the%20subject&cc=someone_else@example.com&body=This%20is%20the%20body">Send email</a> + (message-mail) + (message-mailto-1 (pop command-line-args-left))) + +(defun message-mailto-1 (url) + (let ((args (message-parse-mailto-url url))) + (dolist (arg args) + (unless (equal (car arg) "body") + (message-position-on-field (capitalize (car arg))) + (insert (replace-regexp-in-string + "\r\n" "\n" + (mapconcat #'identity (reverse (cdr arg)) ", ") nil t)))) + (when (assoc "body" args) + (message-goto-body) + (dolist (body (cdr (assoc "body" args))) + (insert body "\n"))) + (if (assoc "subject" args) + (message-goto-body) + (message-goto-subject)))) + (provide 'message) +(make-obsolete-variable 'message-load-hook + "use `with-eval-after-load' instead." "28.1") (run-hooks 'message-load-hook) ;; Local Variables: diff --git a/lisp/gnus/mm-archive.el b/lisp/gnus/mm-archive.el index 6b4308e9790..56253afa193 100644 --- a/lisp/gnus/mm-archive.el +++ b/lisp/gnus/mm-archive.el @@ -24,6 +24,7 @@ (require 'mm-decode) (autoload 'gnus-recursive-directory-files "gnus-util") +(autoload 'gnus-get-buffer-create "gnus") (autoload 'mailcap-extension-to-mime "mailcap") (defvar mm-archive-decoders @@ -41,8 +42,9 @@ dir) (unless decoder (error "No decoder found for %s" type)) - (setq dir (make-temp-file (expand-file-name "emm." mm-tmp-directory) 'dir)) - (set-file-modes dir #o700) + (with-file-modes #o700 + (setq dir (make-temp-file (expand-file-name "emm." mm-tmp-directory) + 'dir))) (unwind-protect (progn (mm-with-unibyte-buffer @@ -56,7 +58,7 @@ (append (cdr decoder) (list dir))) (delete-file file)) (apply 'call-process-region (point-min) (point-max) (car decoder) - nil (get-buffer-create "*tnef*") + nil (gnus-get-buffer-create "*tnef*") nil (append (cdr decoder) (list dir))))) `("multipart/mixed" ,handle diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index a340418507f..1bce6ca020e 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -602,11 +602,10 @@ files left at the next time." (push temp fails))) (if fails ;; Schedule the deletion of the files left at the next time. - (progn + (with-file-modes #o600 (write-region (concat (mapconcat 'identity (nreverse fails) "\n") "\n") - nil cache-file nil 'silent) - (set-file-modes cache-file #o600)) + nil cache-file nil 'silent)) (when (file-exists-p cache-file) (ignore-errors (delete-file cache-file)))) (setq mm-temp-files-to-be-deleted nil))) @@ -911,8 +910,10 @@ external if displayed external." ;; The function is a string to be executed. (mm-insert-part handle) (mm-add-meta-html-tag handle) - (let* ((dir (make-temp-file - (expand-file-name "emm." mm-tmp-directory) 'dir)) + ;; We create a private sub-directory where we store our files. + (let* ((dir (with-file-modes #o700 + (make-temp-file + (expand-file-name "emm." mm-tmp-directory) 'dir))) (filename (or (mail-content-type-get (mm-handle-disposition handle) 'filename) @@ -924,8 +925,6 @@ external if displayed external." (assoc "needsterminal" mime-info))) (copiousoutput (assoc "copiousoutput" mime-info)) file buffer) - ;; We create a private sub-directory where we store our files. - (set-file-modes dir #o700) (if filename (setq file (expand-file-name (gnus-map-function mm-file-name-rewrite-functions @@ -941,14 +940,15 @@ external if displayed external." ;; `mailcap-mime-extensions'. (setq suffix (car (rassoc (mm-handle-media-type handle) mailcap-mime-extensions)))) - (setq file (make-temp-file (expand-file-name "mm." dir) - nil suffix)))) + (setq file (with-file-modes #o600 + (make-temp-file (expand-file-name "mm." dir) + nil suffix))))) (let ((coding-system-for-write mm-binary-coding-system)) (write-region (point-min) (point-max) file nil 'nomesg)) ;; The file is deleted after the viewer exists. If the users edits ;; the file, changes will be lost. Set file to read-only to make it ;; clear. - (set-file-modes file #o400) + (set-file-modes file #o400 'nofollow) (message "Viewing with %s" method) (cond (needsterm @@ -1364,10 +1364,7 @@ PROMPT overrides the default one used to ask user for a file name." (setq file (read-file-name (or prompt - (format "Save MIME part to%s: " - (if filename - (format " (default %s)" filename) - ""))) + (format-prompt "Save MIME part to" filename)) (or directory mm-default-directory default-directory) (expand-file-name (or filename "") @@ -1668,18 +1665,26 @@ If RECURSIVE, search recursively." (let ((type (car ctl)) (subtype (cadr (split-string (car ctl) "/"))) (mm-security-handle ctl) ;; (car CTL) is the type. + (smime-type (cdr (assq 'smime-type (mm-handle-type parts)))) protocol func functest) (cond ((or (equal type "application/x-pkcs7-mime") (equal type "application/pkcs7-mime")) (with-temp-buffer (when (and (cond + ((equal smime-type "signed-data") t) ((eq mm-decrypt-option 'never) nil) ((eq mm-decrypt-option 'always) t) ((eq mm-decrypt-option 'known) t) (t (y-or-n-p (format "Decrypt (S/MIME) part? ")))) (mm-view-pkcs7 parts from)) + (goto-char (point-min)) + ;; The encrypted document is a MIME part, and may use either + ;; CRLF (Outlook and the like) or newlines for end-of-line + ;; markers. Translate from CRLF. + (while (search-forward "\r\n" nil t) + (replace-match "\n")) ;; Normally there will be a Content-type header here, but ;; some mailers don't add that to the encrypted part, which ;; makes the subsequent re-dissection fail here. @@ -1688,7 +1693,21 @@ If RECURSIVE, search recursively." (unless (mail-fetch-field "content-type") (goto-char (point-max)) (insert "Content-type: text/plain\n\n"))) - (setq parts (mm-dissect-buffer t))))) + (setq parts + (if (equal smime-type "signed-data") + (list (propertize + "multipart/signed" + 'protocol "application/pkcs7-signature" + 'gnus-info + (format + "%s:%s" + (get-text-property 0 'gnus-info + (car mm-security-handle)) + (get-text-property 0 'gnus-details + (car mm-security-handle)))) + (mm-dissect-buffer t) + parts) + (mm-dissect-buffer t)))))) ((equal subtype "signed") (unless (and (setq protocol (mm-handle-multipart-ctl-parameter ctl 'protocol)) diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index 7629d5cb151..958e24c39f5 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -70,7 +70,7 @@ (mm-coding-system-p 'cp932)) '((windows-31j . cp932))) ;; Charset name: GBK, Charset aliases: CP936, MS936, windows-936 - ;; http://www.iana.org/assignments/charset-reg/GBK + ;; https://www.iana.org/assignments/charset-reg/GBK ;; Emacs 22.1 has cp936, but not gbk, so we alias it: ,@(when (and (not (mm-coding-system-p 'gbk)) (mm-coding-system-p 'cp936)) @@ -131,10 +131,6 @@ is not available." (cond ((null charset) charset) - ;; Running in a non-MULE environment. - ((or (null (mm-get-coding-system-list)) - (not (fboundp 'coding-system-get))) - charset) ;; Check override list quite early. Should only used for decoding, not for ;; encoding! ((and allow-override @@ -295,77 +291,16 @@ superset of iso-8859-1." (defvar mm-universal-coding-system mm-auto-save-coding-system "The universal coding system.") -;; Fixme: some of the cars here aren't valid MIME charsets. That -;; should only matter with XEmacs, though. (defvar mm-mime-mule-charset-alist - '((us-ascii ascii) - (iso-8859-1 latin-iso8859-1) - (iso-8859-2 latin-iso8859-2) - (iso-8859-3 latin-iso8859-3) - (iso-8859-4 latin-iso8859-4) - (iso-8859-5 cyrillic-iso8859-5) - ;; Non-mule (X)Emacs uses the last mule-charset for 8bit characters. - ;; The fake mule-charset, gnus-koi8-r, tells Gnus that the default - ;; charset is koi8-r, not iso-8859-5. - (koi8-r cyrillic-iso8859-5 gnus-koi8-r) - (iso-8859-6 arabic-iso8859-6) - (iso-8859-7 greek-iso8859-7) - (iso-8859-8 hebrew-iso8859-8) - (iso-8859-9 latin-iso8859-9) - (iso-8859-14 latin-iso8859-14) - (iso-8859-15 latin-iso8859-15) - (viscii vietnamese-viscii-lower) - (iso-2022-jp latin-jisx0201 japanese-jisx0208 japanese-jisx0208-1978) - (euc-kr korean-ksc5601) - (gb2312 chinese-gb2312) - (gbk chinese-gbk) - (gb18030 gb18030-2-byte - gb18030-4-byte-bmp gb18030-4-byte-smp - gb18030-4-byte-ext-1 gb18030-4-byte-ext-2) - (big5 chinese-big5-1 chinese-big5-2) - (tibetan tibetan) - (thai-tis620 thai-tis620) - (windows-1251 cyrillic-iso8859-5) - (iso-2022-7bit ethiopic arabic-1-column arabic-2-column) - (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7 - latin-jisx0201 japanese-jisx0208-1978 - chinese-gb2312 japanese-jisx0208 - korean-ksc5601 japanese-jisx0212) - (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7 - latin-jisx0201 japanese-jisx0208-1978 - chinese-gb2312 japanese-jisx0208 - korean-ksc5601 japanese-jisx0212 - chinese-cns11643-1 chinese-cns11643-2) - (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2 - cyrillic-iso8859-5 greek-iso8859-7 - latin-jisx0201 japanese-jisx0208-1978 - chinese-gb2312 japanese-jisx0208 - korean-ksc5601 japanese-jisx0212 - chinese-cns11643-1 chinese-cns11643-2 - chinese-cns11643-3 chinese-cns11643-4 - chinese-cns11643-5 chinese-cns11643-6 - chinese-cns11643-7) - (iso-2022-jp-3 latin-jisx0201 japanese-jisx0208-1978 japanese-jisx0208 - japanese-jisx0213-1 japanese-jisx0213-2) - (shift_jis latin-jisx0201 katakana-jisx0201 japanese-jisx0208) - (utf-8)) - "Alist of MIME-charset/MULE-charsets.") - -;; Correct by construction, but should be unnecessary for Emacs: -(when (and (fboundp 'coding-system-list) - (fboundp 'sort-coding-systems)) - (let ((css (sort-coding-systems (coding-system-list 'base-only))) - cs mime mule alist) - (while css - (setq cs (pop css) - mime (or (coding-system-get cs :mime-charset) ; Emacs 23 (unicode) - (coding-system-get cs 'mime-charset))) + (let (mime mule alist) + (dolist (cs (sort-coding-systems (coding-system-list 'base-only))) + (setq mime (coding-system-get cs 'mime-charset)) (when (and mime - (not (eq t (setq mule - (coding-system-get cs 'safe-charsets)))) + (not (eq t (setq mule (coding-system-get cs 'safe-charsets)))) (not (assq mime alist))) (push (cons mime (delq 'ascii mule)) alist))) - (setq mm-mime-mule-charset-alist (nreverse alist)))) + (nreverse alist)) + "Alist of MIME-charset/MULE-charsets.") (defvar mm-hack-charsets '(iso-8859-15 iso-2022-jp-2) "A list of special charsets. diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el index e6fdc93da24..aedd6c948c2 100644 --- a/lisp/gnus/mm-uu.el +++ b/lisp/gnus/mm-uu.el @@ -192,7 +192,7 @@ This can be either \"inline\" or \"attachment\".") ,(lambda () (mm-uu-verbatim-marks-extract 0 0)) nil) (LaTeX - "^\\([\\\\%][^\n]+\n\\)*\\\\documentclass.*[[{%]" + "^\\([\\%][^\n]+\n\\)*\\\\documentclass.*[[{%]" "^\\\\end{document}" ,#'mm-uu-latex-extract nil @@ -251,19 +251,23 @@ The value should be nil on displays where the face (((type tty) (class color) (background dark)) - (:background "dark blue")) + (:background "dark blue" + :extend t)) (((class color) (background dark)) (:foreground "light yellow" - :background "dark green")) + :background "dark green" + :extend t)) (((type tty) (class color) (background light)) - (:foreground "dark blue")) + (:foreground "dark blue" + :extend t)) (((class color) (background light)) (:foreground "dark green" - :background "light yellow")) + :background "light yellow" + :extend t)) (t ())) "Face for extracted buffers." diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index 828ac633dc5..ca610010917 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -59,11 +59,16 @@ "The attributes of renderer types for text/html.") (defcustom mm-fill-flowed t - "If non-nil a format=flowed article will be displayed flowed." + "If non-nil, format=flowed articles will be displayed flowed." :type 'boolean :version "22.1" :group 'mime-display) +;; Not a defcustom, since it's usually overridden by the callers of +;; the mm functions. +(defvar mm-inline-font-lock t + "If non-nil, do font locking of inline media types that support it.") + (defcustom mm-inline-large-images-proportion 0.9 "Maximum proportion large images can occupy in the buffer. This is only used if `mm-inline-large-images' is set to @@ -502,7 +507,8 @@ If MODE is not set, try to find mode automatically." (delay-mode-hooks (set-auto-mode)) (setq mode major-mode))) ;; Do not fontify if the guess mode is fundamental. - (unless (eq major-mode 'fundamental-mode) + (when (and (not (eq major-mode 'fundamental-mode)) + mm-inline-font-lock) (font-lock-ensure)))) (setq text (buffer-string)) (when (eq mode 'diff-mode) @@ -540,7 +546,7 @@ If MODE is not set, try to find mode automatically." (mm-display-inline-fontify handle 'shell-script-mode)) (defun mm-display-javascript-inline (handle) - "Show JavsScript code from HANDLE inline." + "Show JavaScript code from HANDLE inline." (mm-display-inline-fontify handle 'javascript-mode)) ;; id-signedData OBJECT IDENTIFIER ::= { iso(1) member-body(2) @@ -591,8 +597,16 @@ If MODE is not set, try to find mode automatically." (with-temp-buffer (insert-buffer-substring (mm-handle-buffer handle)) (goto-char (point-min)) - (let ((part (base64-decode-string (buffer-string)))) - (epg-verify-string (epg-make-context 'CMS) part)))) + (let ((part (base64-decode-string (buffer-string))) + (context (epg-make-context 'CMS))) + (prog1 + (epg-verify-string context part) + (let ((result (car (epg-context-result-for context 'verify)))) + (mm-sec-status + 'gnus-info (epg-signature-status result) + 'gnus-details + (format "%s:%s" (epg-signature-validity result) + (epg-signature-key-id result)))))))) (with-temp-buffer (insert "MIME-Version: 1.0\n") (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m") diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el index 8d77916e997..74af99da7e3 100644 --- a/lisp/gnus/mml-sec.el +++ b/lisp/gnus/mml-sec.el @@ -665,8 +665,9 @@ The passphrase is read and cached." (epg-user-id-string uid)))) (equal (downcase (car (mail-header-parse-address (epg-user-id-string uid)))) - (downcase (car (mail-header-parse-address - recipient)))) + (downcase (or (car (mail-header-parse-address + recipient)) + recipient))) (not (memq (epg-user-id-validity uid) '(revoked expired)))) (throw 'break t)))))) @@ -937,6 +938,48 @@ If no one is selected, symmetric encryption will be performed. " (signal (car error) (cdr error)))) cipher)) +(defun mml-secure-sender-sign-query (protocol sender) + "Query whether to use SENDER to sign when using PROTOCOL. +PROTOCOL will be `OpenPGP' or `CMS' (smime). +This can also save the resulting value of +`mml-secure-smime-sign-with-sender' or +`mml-secure-openpgp-sign-with-sender' via Customize. +Returns non-nil if the user has chosen to use SENDER." + (let ((buffer (get-buffer-create "*MML sender signing options*")) + (options '((?a "always" "Sign using this sender now and sign with message sender in future.") + (?s "session only" "Sign using this sender now, and sign with message sender for this session only.") + (?n "no" "Do not sign this message (and error out)"))) + answer done val) + (save-window-excursion + (pop-to-buffer buffer) + (erase-buffer) + (insert (format "No %s signing key was found for this message.\nThe sender of this message is \"%s\".\nWould you like to attempt looking up a signing key based on it?" + (if (eq protocol 'OpenPGP) + "openpgp" "smime") + sender)) + (while (not done) + (setq answer (read-multiple-choice "Sign this message using the sender?" options)) + (cl-case (car answer) + (?a + (if (eq protocol 'OpenPGP) + (progn + (setq mml-secure-openpgp-sign-with-sender t) + (customize-save-variable + 'mml-secure-openpgp-sign-with-sender t)) + (setq mml-secure-smime-sign-with-sender t) + (customize-save-variable 'mml-secure-smime-sign-with-sender t)) + (setq done t + val t)) + (?s + (if (eq protocol 'OpenPGP) + (setq mml-secure-openpgp-sign-with-sender t) + (setq mml-secure-smime-sign-with-sender t)) + (setq done t + val t)) + (?n + (setq done t))))) + val)) + (defun mml-secure-epg-sign (protocol mode) ;; Based on code appearing inside mml2015-epg-sign. (let* ((context (epg-make-context protocol)) @@ -944,6 +987,23 @@ If no one is selected, symmetric encryption will be performed. " (signer-names (mml-secure-signer-names protocol sender)) (signers (mml-secure-signers context signer-names)) signature micalg) + (unless signers + (if (and (not noninteractive) + (mml-secure-sender-sign-query protocol sender)) + (setq signer-names (mml-secure-signer-names protocol sender) + signers (mml-secure-signers context signer-names))) + (unless signers + (let ((maybe-msg + (if (or mml-secure-smime-sign-with-sender + mml-secure-openpgp-sign-with-sender) + "." + "; try setting `mml-secure-smime-sign-with-sender' or 'mml-secure-openpgp-sign-with-sender'."))) + ;; If `mml-secure-smime-sign-with-sender' or + ;; `mml-secure-openpgp-sign-with-sender' are already non-nil + ;; then there's no point advising the user to examine them. + ;; If there are any other variables worth examining, please + ;; improve this error message by having it mention them. + (error "Couldn't find any signer names%s" maybe-msg)))) (when (eq 'OpenPGP protocol) (setf (epg-context-armor context) t) (setf (epg-context-textmode context) t) diff --git a/lisp/gnus/mml-smime.el b/lisp/gnus/mml-smime.el index 3cc463d5d4c..acddb300339 100644 --- a/lisp/gnus/mml-smime.el +++ b/lisp/gnus/mml-smime.el @@ -154,14 +154,9 @@ Whether the passphrase is cached at all is controlled by (write-region (point-min) (point-max) file)) (push file certfiles) (push file tmpfiles))) - (if (smime-encrypt-buffer certfiles) - (progn - (while (setq tmp (pop tmpfiles)) - (delete-file tmp)) - t) - (while (setq tmp (pop tmpfiles)) - (delete-file tmp)) - nil)) + (smime-encrypt-buffer certfiles) + (while (setq tmp (pop tmpfiles)) + (delete-file tmp))) (goto-char (point-max))) (defvar gnus-extract-address-components) @@ -334,7 +329,6 @@ Whether the passphrase is cached at all is controlled by (autoload 'epg-verify-string "epg") (autoload 'epg-sign-string "epg") (autoload 'epg-encrypt-string "epg") - (autoload 'epg-passphrase-callback-function "epg") (autoload 'epg-context-set-passphrase-callback "epg") (autoload 'epg-sub-key-fingerprint "epg") (autoload 'epg-configuration "epg-config") diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 556cf0804a5..067396fc2a6 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -295,6 +295,17 @@ part. This is for the internal use, you should never modify the value.") (t (mm-find-mime-charset-region point (point) mm-hack-charsets)))) + ;; We have a part that already has a transfer encoding. Undo + ;; that so that we don't double-encode later. + (when (and raw + (cdr (assq 'data-encoding tag))) + (with-temp-buffer + (set-buffer-multibyte nil) + (insert contents) + (mm-decode-content-transfer-encoding + (intern (cdr (assq 'data-encoding tag))) + (cdr (assq 'type tag))) + (setq contents (buffer-string)))) (when (and (not raw) (memq nil charsets)) (if (or (memq 'unknown-encoding mml-confirmation-set) (message-options-get 'unknown-encoding) @@ -313,8 +324,8 @@ Message contains characters with unknown encoding. Really send? ") (eq 'mml (car tag)) (< (length charsets) 2)) (if (or (not no-markup-p) + ;; Don't create blank parts. (string-match "[^ \t\r\n]" contents)) - ;; Don't create blank parts. (push (nconc tag (list (cons 'contents contents))) struct)) (let ((nstruct (mml-parse-singlepart-with-multiple-charsets @@ -487,11 +498,8 @@ type detected." (= (length cont) 1) content-type) (setcdr (assq 'type (cdr (car cont))) content-type)) - (when (and (consp (car cont)) - (= (length cont) 1) - (fboundp 'libxml-parse-html-region) - (equal (cdr (assq 'type (car cont))) "text/html")) - (setq cont (mml-expand-html-into-multipart-related (car cont)))) + (when (fboundp 'libxml-parse-html-region) + (setq cont (mapcar 'mml-expand-all-html-into-multipart-related cont))) (prog1 (with-temp-buffer (set-buffer-multibyte nil) @@ -510,6 +518,18 @@ type detected." (buffer-string)) (setq message-options options))))) +(defun mml-expand-all-html-into-multipart-related (cont) + (cond ((and (eq (car cont) 'part) + (equal (cdr (assq 'type cont)) "text/html")) + (mml-expand-html-into-multipart-related cont)) + ((eq (car cont) 'multipart) + (let ((cur (cdr cont))) + (while (consp cur) + (setcar cur (mml-expand-all-html-into-multipart-related (car cur))) + (setf cur (cdr cur)))) + cont) + (t cont))) + (defun mml-expand-html-into-multipart-related (cont) (let ((new-parts nil) (cid 1)) @@ -538,8 +558,7 @@ type detected." new-parts)) (setq cid (1+ cid))))))) ;; We have local images that we want to include. - (if (not new-parts) - (list cont) + (when new-parts (setcdr (assq 'contents cont) (buffer-string)) (setq cont (nconc (list 'multipart (cons 'type "related")) @@ -552,8 +571,8 @@ type detected." (nth 1 new-part) (nth 2 new-part)) (id . ,(concat "<" (nth 0 new-part) - ">"))))))) - cont)))) + ">")))))))) + cont))) (autoload 'image-property "image") @@ -1341,7 +1360,7 @@ If not set, `default-directory' will be used." (value (pop plist))) (when value ;; Quote VALUE if it contains suspicious characters. - (when (string-match "[\"'\\~/*;() \t\n[:multibyte:]]" value) + (when (string-match "[][\"'\\~/*;()<>= \t\n[:multibyte:]]" value) (setq value (with-output-to-string (let (print-escape-nonascii) (prin1 value))))) diff --git a/lisp/gnus/mml1991.el b/lisp/gnus/mml1991.el index 8be1b84e52f..88864ea3579 100644 --- a/lisp/gnus/mml1991.el +++ b/lisp/gnus/mml1991.el @@ -242,7 +242,6 @@ Whether the passphrase is cached at all is controlled by (defvar epg-user-id-alist) (autoload 'epg-make-context "epg") -(autoload 'epg-passphrase-callback-function "epg") (autoload 'epa-select-keys "epa") (autoload 'epg-list-keys "epg") (autoload 'epg-context-set-armor "epg") diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el index 1e72f681797..45c9bbfe905 100644 --- a/lisp/gnus/mml2015.el +++ b/lisp/gnus/mml2015.el @@ -293,6 +293,8 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (substring alg (match-end 0)) alg)))) +(autoload 'gnus-get-buffer-create "gnus") + (defun mml2015-mailcrypt-verify (handle ctl) (catch 'error (let (part) @@ -330,7 +332,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (replace-match "-----BEGIN PGP SIGNATURE-----" t t)) (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t) (replace-match "-----END PGP SIGNATURE-----" t t))) - (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*"))) + (let ((mc-gpg-debug-buffer (gnus-get-buffer-create " *gnus gpg debug*"))) (unless (condition-case err (prog1 (funcall mml2015-verify-function) @@ -359,7 +361,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." handle))) (defun mml2015-mailcrypt-clear-verify () - (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*"))) + (let ((mc-gpg-debug-buffer (gnus-get-buffer-create " *gnus gpg debug*"))) (if (condition-case err (prog1 (funcall mml2015-verify-function) @@ -710,7 +712,6 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (autoload 'epg-verify-string "epg") (autoload 'epg-sign-string "epg") (autoload 'epg-encrypt-string "epg") -(autoload 'epg-passphrase-callback-function "epg") (autoload 'epg-context-set-passphrase-callback "epg") (autoload 'epg-key-sub-key-list "epg") (autoload 'epg-sub-key-capability "epg") @@ -725,6 +726,8 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (autoload 'epg-expand-group "epg-config") (autoload 'epa-select-keys "epa") +(autoload 'gnus-create-image "gnus-util") + (defun mml2015-epg-key-image (key-id) "Return the image of a key, if any." (with-temp-buffer @@ -949,7 +952,6 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." ;;; General wrapper (autoload 'gnus-buffer-live-p "gnus-util") -(autoload 'gnus-get-buffer-create "gnus") (defun mml2015-clean-buffer () (if (gnus-buffer-live-p mml2015-result-buffer) diff --git a/lisp/gnus/nnbabyl.el b/lisp/gnus/nnbabyl.el index 6890f1dceeb..480d794b9ac 100644 --- a/lisp/gnus/nnbabyl.el +++ b/lisp/gnus/nnbabyl.el @@ -293,7 +293,7 @@ (deffoo nnbabyl-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nnbabyl move*")) + (let ((buf (gnus-get-buffer-create " *nnbabyl move*")) result) (and (nnbabyl-request-article article group server) @@ -544,7 +544,7 @@ (setq buffer-file-name nnbabyl-mbox-file) (insert "BABYL OPTIONS:\n\n\^_") (nnmail-write-region - (point-min) (point-max) nnbabyl-mbox-file t 'nomesg)))) + (point-min) (point-max) nnbabyl-mbox-file t 'nomesg nil 'excl)))) (defun nnbabyl-read-mbox () (nnmail-activate 'nnbabyl) diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index a7657c68556..ccd17744993 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -597,7 +597,7 @@ all. This may very well take some time.") (deffoo nndiary-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nndiary move*")) + (let ((buf (gnus-get-buffer-create " *nndiary move*")) result) (nndiary-possibly-change-directory group server) (nndiary-update-file-alist) @@ -831,7 +831,7 @@ all. This may very well take some time.") ;; Find an article number in the current group given the Message-ID. (defun nndiary-find-group-number (id) - (with-current-buffer (get-buffer-create " *nndiary id*") + (with-current-buffer (gnus-get-buffer-create " *nndiary id*") (let ((alist nndiary-group-alist) number) ;; We want to look through all .overview files, but we want to @@ -992,15 +992,15 @@ all. This may very well take some time.") (narrow-to-region (goto-char (point-min)) (if (search-forward "\n\n" nil t) (1- (point)) (point-max)))) - (let ((headers (nnheader-parse-naked-head))) + (let ((headers (nnheader-parse-head t))) (setf (mail-header-chars headers) chars) (setf (mail-header-number headers) number) headers)))) (defun nndiary-open-nov (group) (or (cdr (assoc group nndiary-nov-buffer-alist)) - (let ((buffer (get-buffer-create (format " *nndiary overview %s*" - group)))) + (let ((buffer (gnus-get-buffer-create + (format " *nndiary overview %s*" group)))) (with-current-buffer buffer (set (make-local-variable 'nndiary-nov-buffer-file-name) (expand-file-name @@ -1086,7 +1086,7 @@ all. This may very well take some time.") (defun nndiary-generate-nov-file (dir files) (let* ((dir (file-name-as-directory dir)) (nov (concat dir nndiary-nov-file-name)) - (nov-buffer (get-buffer-create " *nov*")) + (nov-buffer (gnus-get-buffer-create " *nov*")) chars file headers) ;; Init the nov buffer. (with-current-buffer nov-buffer @@ -1115,7 +1115,7 @@ all. This may very well take some time.") (widen)) (setq files (cdr files))) (with-current-buffer nov-buffer - (nnmail-write-region 1 (point-max) nov nil 'nomesg) + (nnmail-write-region 1 (point-max) nov nil 'nomesg nil 'excl) (kill-buffer (current-buffer)))))) (defun nndiary-nov-delete-article (group article) @@ -1425,7 +1425,7 @@ all. This may very well take some time.") (pop years))) (if years ;; Because we might not be limited in years, we must guard against - ;; infinite loops. Appart from cases like Feb 31, there are probably + ;; infinite loops. Apart from cases like Feb 31, there are probably ;; other ones, (no monday XXX 2nd etc). I don't know any algorithm to ;; decide this, so I assume that if we reach 10 years later, the ;; schedule is undecidable. diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el index 0ba63915c94..81431270d7c 100644 --- a/lisp/gnus/nndoc.el +++ b/lisp/gnus/nndoc.el @@ -347,12 +347,13 @@ from the document.") (file-exists-p nndoc-address) (not (file-directory-p nndoc-address)))) (push (cons group (setq nndoc-current-buffer - (get-buffer-create + (gnus-get-buffer-create (concat " *nndoc " group "*")))) nndoc-group-alist) (setq nndoc-dissection-alist nil) (with-current-buffer nndoc-current-buffer (erase-buffer) + (set-buffer-multibyte nil) (condition-case error (if (and (stringp nndoc-address) (string-match nndoc-binary-file-names nndoc-address)) diff --git a/lisp/gnus/nndraft.el b/lisp/gnus/nndraft.el index a1337e8d7fa..a3c26ea4ac0 100644 --- a/lisp/gnus/nndraft.el +++ b/lisp/gnus/nndraft.el @@ -231,7 +231,7 @@ are generated if and only if they are also in `message-draft-headers'." (deffoo nndraft-request-move-article (article group server accept-form &optional last move-is-internal) (nndraft-possibly-change-group group) - (let ((buf (get-buffer-create " *nndraft move*")) + (let ((buf (gnus-get-buffer-create " *nndraft move*")) result) (and (nndraft-request-article article group server) @@ -325,7 +325,7 @@ are generated if and only if they are also in `message-draft-headers'." (save-excursion (prog1 (progn - (set-buffer (get-buffer-create " *draft tmp*")) + (set-buffer (gnus-get-buffer-create " *draft tmp*")) (setq buffer-file-name file) (make-auto-save-file-name)) (kill-buffer (current-buffer))))) diff --git a/lisp/gnus/nneething.el b/lisp/gnus/nneething.el index 9e190515f18..9f1fdbae5ae 100644 --- a/lisp/gnus/nneething.el +++ b/lisp/gnus/nneething.el @@ -381,7 +381,7 @@ included.") (defun nneething-get-head (file) "Either find the head in FILE or make a head for FILE." - (with-current-buffer (get-buffer-create nneething-work-buffer) + (with-current-buffer (gnus-get-buffer-create nneething-work-buffer) (setq case-fold-search nil) (buffer-disable-undo) (erase-buffer) diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el index 342ac48ba85..6ff99056d84 100644 --- a/lisp/gnus/nnfolder.el +++ b/lisp/gnus/nnfolder.el @@ -465,7 +465,7 @@ all. This may very well take some time.") (deffoo nnfolder-request-move-article (article group server accept-form &optional last move-is-internal) (save-excursion - (let ((buf (get-buffer-create " *nnfolder move*")) + (let ((buf (gnus-get-buffer-create " *nnfolder move*")) result) (and (nnfolder-request-article article group server) @@ -735,7 +735,7 @@ deleted. Point is left where the deleted region was." (or nnfolder-file-coding-system-for-write nnfolder-file-coding-system-for-write))) (nnmail-write-region (point-min) (point-min) - file t 'nomesg))) + file t 'nomesg nil 'excl))) (when (setq nnfolder-current-buffer (nnfolder-read-folder group)) (set-buffer nnfolder-current-buffer) (push (list group nnfolder-current-buffer) @@ -1096,7 +1096,7 @@ This command does not work if you use short group names." (defun nnfolder-open-nov (group) (or (cdr (assoc group nnfolder-nov-buffer-alist)) - (let ((buffer (get-buffer-create (format " *nnfolder overview %s*" group)))) + (let ((buffer (gnus-get-buffer-create (format " *nnfolder overview %s*" group)))) (with-current-buffer buffer (set (make-local-variable 'nnfolder-nov-buffer-file-name) (nnfolder-group-nov-pathname group)) @@ -1160,7 +1160,7 @@ This command does not work if you use short group names." (if (search-forward "\n\n" e t) (setq e (1- (point))))) (with-temp-buffer (insert-buffer-substring buf b e) - (let ((headers (nnheader-parse-naked-head))) + (let ((headers (nnheader-parse-head t))) (setf (mail-header-chars headers) chars) (setf (mail-header-number headers) number) headers))))) diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el index 03b08854b11..2952e20928b 100644 --- a/lisp/gnus/nnheader.el +++ b/lisp/gnus/nnheader.el @@ -28,6 +28,10 @@ (eval-when-compile (require 'cl-lib)) +(defvar gnus-decode-encoded-word-function) +(defvar gnus-decode-encoded-address-function) +(defvar gnus-alter-header-function) + (defvar nnmail-extra-headers) (defvar gnus-newsgroup-name) (defvar jka-compr-compression-info-list) @@ -39,6 +43,7 @@ (require 'mail-utils) (require 'mm-util) (require 'gnus-util) +(autoload 'gnus-remove-odd-characters "gnus-sum") (autoload 'gnus-range-add "gnus-range") (autoload 'gnus-remove-from-range "gnus-range") ;; FIXME none of these are used explicitly in this file. @@ -188,124 +193,166 @@ on your system, you could say something like: (autoload 'ietf-drums-unfold-fws "ietf-drums") -(defun nnheader-parse-naked-head (&optional number) - ;; This function unfolds continuation lines in this buffer - ;; destructively. When this side effect is unwanted, use - ;; `nnheader-parse-head' instead of this function. - (let ((case-fold-search t) - (buffer-read-only nil) + +(defsubst nnheader-head-make-header (number) + "Return a full mail header with article NUMBER. +Do this using data of type `head' in the current buffer." + (let ((p (point-min)) (cur (current-buffer)) - (p (point-min)) - in-reply-to lines ref) - (nnheader-remove-cr-followed-by-lf) - (ietf-drums-unfold-fws) - (subst-char-in-region (point-min) (point-max) ?\t ? ) - (goto-char p) - (insert "\n") - (prog1 - ;; This implementation of this function, with nine - ;; search-forwards instead of the one re-search-forward and a - ;; case (which basically was the old function) is actually - ;; about twice as fast, even though it looks messier. You - ;; can't have everything, I guess. Speed and elegance don't - ;; always go hand in hand. - (vector - ;; Number. - (or number 0) - ;; Subject. - (progn - (goto-char p) - (if (search-forward "\nsubject:" nil t) - (nnheader-header-value) "(none)")) - ;; From. - (progn - (goto-char p) - (if (search-forward "\nfrom:" nil t) - (nnheader-header-value) "(nobody)")) - ;; Date. - (progn - (goto-char p) - (if (search-forward "\ndate:" nil t) - (nnheader-header-value) "")) - ;; Message-ID. - (progn - (goto-char p) - (if (search-forward "\nmessage-id:" nil t) - (buffer-substring - (1- (or (search-forward "<" (point-at-eol) t) - (point))) - (or (search-forward ">" (point-at-eol) t) (point))) - ;; If there was no message-id, we just fake one to make - ;; subsequent routines simpler. - (nnheader-generate-fake-message-id number))) - ;; References. - (progn + in-reply-to chars lines end ref) + ;; This implementation of this function, with nine + ;; search-forwards instead of the one re-search-forward and a + ;; case (which basically was the old function) is actually + ;; about twice as fast, even though it looks messier. You + ;; can't have everything, I guess. Speed and elegance don't + ;; always go hand in hand. + (make-full-mail-header + ;; Number. + number + ;; Subject. + (progn + (goto-char p) + (if (search-forward "\nsubject:" nil t) + (funcall gnus-decode-encoded-word-function + (nnheader-header-value)) + "(none)")) + ;; From. + (progn + (goto-char p) + (if (search-forward "\nfrom:" nil t) + (funcall gnus-decode-encoded-address-function + (nnheader-header-value)) + "(nobody)")) + ;; Date. + (progn + (goto-char p) + (if (search-forward "\ndate:" nil t) + (nnheader-header-value) "")) + ;; Message-ID. + (progn + (goto-char p) + (if (re-search-forward + "^message-id: *\\(<[^\n\t> ]+>\\)" nil t) + ;; We do it this way to make sure the Message-ID + ;; is (somewhat) syntactically valid. + (buffer-substring (match-beginning 1) + (match-end 1)) + ;; If there was no message-id, we just fake one to make + ;; subsequent routines simpler. + (nnheader-generate-fake-message-id number))) + ;; References. + (progn + (goto-char p) + (if (search-forward "\nreferences:" nil t) + (progn + (setq end (point)) + (prog1 + (nnheader-header-value) + (setq ref + (buffer-substring + (progn + (end-of-line) + (search-backward ">" end t) + (1+ (point))) + (progn + (search-backward "<" end t) + (point)))))) + ;; Get the references from the in-reply-to header if there + ;; were no references and the in-reply-to header looks + ;; promising. + (if (and (search-forward "\nin-reply-to:" nil t) + (setq in-reply-to (nnheader-header-value)) + (string-match "<[^>]+>" in-reply-to)) + (let (ref2) + (setq ref (substring in-reply-to (match-beginning 0) + (match-end 0))) + (while (string-match "<[^>]+>" in-reply-to (match-end 0)) + (setq ref2 (substring in-reply-to (match-beginning 0) + (match-end 0))) + (when (> (length ref2) (length ref)) + (setq ref ref2))) + ref) + nil))) + ;; Chars. + (progn + (goto-char p) + (if (search-forward "\nchars: " nil t) + (if (numberp (setq chars (ignore-errors (read cur)))) + chars -1) + -1)) + ;; Lines. + (progn + (goto-char p) + (if (search-forward "\nlines: " nil t) + (if (numberp (setq lines (ignore-errors (read cur)))) + lines -1) + -1)) + ;; Xref. + (progn + (goto-char p) + (and (search-forward "\nxref:" nil t) + (nnheader-header-value))) + ;; Extra. + (when nnmail-extra-headers + (let ((extra nnmail-extra-headers) + out) + (while extra (goto-char p) - (if (search-forward "\nreferences:" nil t) - (nnheader-header-value) - ;; Get the references from the in-reply-to header if - ;; there were no references and the in-reply-to header - ;; looks promising. - (if (and (search-forward "\nin-reply-to:" nil t) - (setq in-reply-to (nnheader-header-value)) - (string-match "<[^\n>]+>" in-reply-to)) - (let (ref2) - (setq ref (substring in-reply-to (match-beginning 0) - (match-end 0))) - (while (string-match "<[^\n>]+>" - in-reply-to (match-end 0)) - (setq ref2 (substring in-reply-to (match-beginning 0) - (match-end 0))) - (when (> (length ref2) (length ref)) - (setq ref ref2))) - ref) - nil))) - ;; Chars. - 0 - ;; Lines. - (progn - (goto-char p) - (if (search-forward "\nlines: " nil t) - (if (numberp (setq lines (read cur))) - lines 0) - 0)) - ;; Xref. - (progn - (goto-char p) - (and (search-forward "\nxref:" nil t) - (nnheader-header-value))) - ;; Extra. - (when nnmail-extra-headers - (let ((extra nnmail-extra-headers) - out) - (while extra - (goto-char p) - (when (search-forward - (concat "\n" (symbol-name (car extra)) ":") nil t) - (push (cons (car extra) (nnheader-header-value)) - out)) - (pop extra)) - out))) - (goto-char p) - (delete-char 1)))) - -(defun nnheader-parse-head (&optional naked) - (let ((cur (current-buffer)) num beg end) - (when (if naked - (setq num 0 - beg (point-min) - end (point-max)) - ;; Search to the beginning of the next header. Error - ;; messages do not begin with 2 or 3. - (when (re-search-forward "^[23][0-9]+ " nil t) - (setq num (read cur) - beg (point) - end (if (search-forward "\n.\n" nil t) - (goto-char (- (point) 2)) - (point))))) - (with-temp-buffer - (insert-buffer-substring cur beg end) - (nnheader-parse-naked-head num))))) + (when (search-forward + (concat "\n" (symbol-name (car extra)) ":") nil t) + (push (cons (car extra) (nnheader-header-value)) + out)) + (pop extra)) + out))))) + +(defun nnheader-parse-head (&optional naked temp) + "Parse data of type `header' in the current buffer and return a mail header. +Modify the buffer contents in the process. The buffer is assumed +to begin each header with an \"Article retrieved\" line with an +article number; if NAKED is non-nil this line is assumed absent, +and the buffer should contain a single header's worth of data. +If TEMP is non-nil the data is first copied to a temporary buffer +leaving the original buffer untouched." + (let ((cur (current-buffer)) + (num 0) + (beg (point-min)) + (end (point-max)) + buf) + (when (or naked + ;; Search to the beginning of the next header. Error + ;; messages do not begin with 2 or 3. + (when (re-search-forward "^[23][0-9]+ " nil t) + (setq num (read cur) + beg (point) + end (if (search-forward "\n.\n" nil t) + (goto-char (- (point) 2)) + (point))))) + ;; When TEMP copy the data to a temporary buffer. + (if temp + (progn + (set-buffer (setq buf (generate-new-buffer " *nnheader-temp*"))) + (insert-buffer-substring cur beg end)) + ;; Otherwise just narrow to the data. + (narrow-to-region beg end)) + (let ((case-fold-search t) + (buffer-read-only nil) + header) + (nnheader-remove-cr-followed-by-lf) + (ietf-drums-unfold-fws) + (subst-char-in-region (point-min) (point-max) ?\t ?\s t) + (subst-char-in-region (point-min) (point-max) ?\r ?\s t) + (goto-char (point-min)) + (insert "\n") + (setq header (nnheader-head-make-header num)) + (goto-char (point-min)) + (delete-char 1) + (if temp + (kill-buffer buf) + (goto-char (point-max)) + (widen)) + (when gnus-alter-header-function + (funcall gnus-alter-header-function header)) + header)))) (defmacro nnheader-nov-skip-field () '(search-forward "\t" eol 'move)) @@ -347,24 +394,43 @@ on your system, you could say something like: 'id) (nnheader-generate-fake-message-id ,number)))) -(defun nnheader-parse-nov () +(defalias 'nnheader-nov-make-header 'nnheader-parse-nov) +(autoload 'gnus-extract-message-id-from-in-reply-to "gnus-sum") + +(defun nnheader-parse-nov (&optional number) (let ((eol (point-at-eol)) - (number (nnheader-nov-read-integer))) - (vector - number ; number - (nnheader-nov-field) ; subject - (nnheader-nov-field) ; from - (nnheader-nov-field) ; date - (nnheader-nov-read-message-id number) ; id - (nnheader-nov-field) ; refs - (nnheader-nov-read-integer) ; chars - (nnheader-nov-read-integer) ; lines - (if (eq (char-after) ?\n) - nil - (if (looking-at "Xref: ") - (goto-char (match-end 0))) - (nnheader-nov-field)) ; Xref - (nnheader-nov-parse-extra)))) ; extra + references in-reply-to x header) + (setq header + (make-full-mail-header + (or number (nnheader-nov-read-integer)) ; number + (condition-case () ; subject + (gnus-remove-odd-characters + (funcall gnus-decode-encoded-word-function + (setq x (nnheader-nov-field)))) + (error x)) + (condition-case () ; from + (gnus-remove-odd-characters + (funcall gnus-decode-encoded-address-function + (setq x (nnheader-nov-field)))) + (error x)) + (nnheader-nov-field) ; date + (nnheader-nov-read-message-id number) ; id + (setq references (nnheader-nov-field)) ; refs + (nnheader-nov-read-integer) ; chars + (nnheader-nov-read-integer) ; lines + (unless (eobp) + (if (looking-at "Xref: ") + (goto-char (match-end 0))) + (nnheader-nov-field)) ; Xref + (nnheader-nov-parse-extra))) ; extra + + (when (and (string= references "") + (setq in-reply-to (mail-header-extra header)) + (setq in-reply-to (cdr (assq 'In-Reply-To in-reply-to)))) + (setf (mail-header-references header) + (gnus-extract-message-id-from-in-reply-to in-reply-to))) + header)) + (defun nnheader-insert-nov (header) (princ (mail-header-number header) (current-buffer)) @@ -399,17 +465,6 @@ on your system, you could say something like: (delete-char 1)) (forward-line 1))) -(defun nnheader-parse-overview-file (file) - "Parse FILE and return a list of headers." - (mm-with-unibyte-buffer - (nnheader-insert-file-contents file) - (goto-char (point-min)) - (let (headers) - (while (not (eobp)) - (push (nnheader-parse-nov) headers) - (forward-line 1)) - (nreverse headers)))) - (defun nnheader-write-overview-file (file headers) "Write HEADERS to FILE." (with-temp-file file @@ -487,8 +542,8 @@ the line could be found." (< num article))) (forward-line 1) (setq found (point)) - (or (eobp) - (= (setq num (read cur)) article))) + (unless (eobp) + (setq num (read cur)))) (unless (eq num article) (goto-char found))) (beginning-of-line) @@ -502,10 +557,12 @@ the line could be found." "Coding system used in file backends of Gnus.") (defvar nnheader-callback-function nil) +(autoload 'gnus-get-buffer-create "gnus") + (defun nnheader-init-server-buffer () "Initialize the Gnus-backend communication buffer." (unless (gnus-buffer-live-p nntp-server-buffer) - (setq nntp-server-buffer (get-buffer-create " *nntpd*"))) + (setq nntp-server-buffer (gnus-get-buffer-create " *nntpd*"))) (with-current-buffer nntp-server-buffer (erase-buffer) (mm-enable-multibyte) @@ -630,7 +687,7 @@ the line could be found." (defun nnheader-set-temp-buffer (name &optional noerase) "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled." - (set-buffer (get-buffer-create name)) + (set-buffer (gnus-get-buffer-create name)) (buffer-disable-undo) (unless noerase (erase-buffer)) @@ -1010,6 +1067,8 @@ See `find-file-noselect' for the arguments." (setq nnheader-last-message-time now) (apply 'nnheader-message args)))) +(make-obsolete-variable 'nnheader-load-hook + "use `with-eval-after-load' instead." "28.1") (run-hooks 'nnheader-load-hook) (provide 'nnheader) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index c383e0146f3..7984998d214 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -365,7 +365,7 @@ textual parts.") (mm-disable-multibyte) (buffer-disable-undo) (gnus-add-buffer) - (set (make-local-variable 'after-change-functions) nil) + (set (make-local-variable 'after-change-functions) nil) ;FIXME: Why? (set (make-local-variable 'nnimap-object) (make-nnimap :server (nnoo-current-server 'nnimap) :initial-resync 0)) @@ -986,7 +986,10 @@ textual parts.") (when (and (car result) (not can-move)) (nnimap-delete-article article)) (cons internal-move-group - (or (nnimap-find-uid-response "COPYUID" (caddr result)) + (or (nnimap-find-uid-response + "COPYUID" + ;; Server gives different responses for MOVE and COPY. + (if can-move (caddr result) (cadr result))) (nnimap-find-article-by-message-id internal-move-group server message-id nnimap-request-articles-find-limit))))) @@ -1670,8 +1673,7 @@ If LIMIT, first try to limit the search to the N last articles." (when (and active recent (> (car (last recent)) (cdr active))) - (push (list (cons (gnus-group-real-name group) 0)) - nnmail-split-history))) + (push (list (cons group 0)) nnmail-split-history))) ;; Note the active level for the next run-through. (gnus-group-set-parameter info 'active (gnus-active group)) (gnus-group-set-parameter info 'uidvalidity uidvalidity) @@ -1684,7 +1686,7 @@ If LIMIT, first try to limit the search to the N last articles." (gnus-add-to-range (gnus-add-to-range (gnus-range-add (gnus-info-read info) - vanished) + vanished) (cdr (assq '%Flagged flags))) (cdr (assq '%Seen flags)))) (let ((marks (gnus-info-marks info))) @@ -1770,11 +1772,6 @@ If LIMIT, first try to limit the search to the N last articles." ;; read it. (subst-char-in-region (point-min) (point-max) ?\\ ?% t) - ;; Remove any MODSEQ entries in the buffer, because they may contain - ;; numbers that are too large for 32-bit Emacsen. - (while (re-search-forward " MODSEQ ([0-9]+)" nil t) - (replace-match "" t t)) - (goto-char (point-min)) (let (start end articles groups uidnext elems permanent-flags uidvalidity vanished highestmodseq) (dolist (elem sequences) @@ -1801,8 +1798,9 @@ If LIMIT, first try to limit the search to the N last articles." (setq uidvalidity (and (re-search-forward "UIDVALIDITY \\([0-9]+\\)" end t) - ;; Store UIDVALIDITY as a string, as it's - ;; too big for 32-bit Emacsen, usually. + ;; Store UIDVALIDITY as a string; before bignums, + ;; it was usually too big for 32-bit Emacsen, + ;; and we don't want to change the format now. (match-string 1))) (goto-char start) (setq vanished @@ -1849,15 +1847,15 @@ If LIMIT, first try to limit the search to the N last articles." (setq nnimap-status-string "Read-only server") nil) -(defvar gnus-refer-thread-use-nnir) ;; gnus-sum.el +(defvar gnus-refer-thread-use-search) ;; gnus-sum.el (declare-function gnus-fetch-headers "gnus-sum" (articles &optional limit force-new dependencies)) -(autoload 'nnir-search-thread "nnir") +(autoload 'nnselect-search-thread "nnselect") (deffoo nnimap-request-thread (header &optional group server) - (if gnus-refer-thread-use-nnir - (nnir-search-thread header) + (if gnus-refer-thread-use-search + (nnselect-search-thread header) (when (nnimap-change-group group server) (let* ((cmd (nnimap-make-thread-query header)) (result (with-current-buffer (nnimap-buffer) @@ -1937,7 +1935,7 @@ Return the server's response to the SELECT or EXAMINE command." (defun nnimap-log-buffer () (let ((name "*imap log*")) (or (get-buffer name) - (with-current-buffer (get-buffer-create name) + (with-current-buffer (gnus-get-buffer-create name) (setq-local window-point-insertion-type t) (current-buffer))))) diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el deleted file mode 100644 index f1e31a0cd10..00000000000 --- a/lisp/gnus/nnir.el +++ /dev/null @@ -1,1917 +0,0 @@ -;;; nnir.el --- Search mail with various search engines -*- lexical-binding:t -*- - -;; Copyright (C) 1998-2020 Free Software Foundation, Inc. - -;; Author: Kai GroΓjohann <grossjohann@ls6.cs.uni-dortmund.de> -;; Swish-e and Swish++ backends by: -;; Christoph Conrad <christoph.conrad@gmx.de>. -;; IMAP backend by: Simon Josefsson <jas@pdc.kth.se>. -;; IMAP search by: Torsten Hilbrich <torsten.hilbrich <at> gmx.net> -;; IMAP search improved by Daniel Pittman <daniel@rimspace.net>. -;; nnmaildir support for Swish++ and Namazu backends by: -;; Justus Piater <Justus <at> Piater.name> -;; Keywords: news mail searching ir - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; What does it do? Well, it allows you to search your mail using -;; some search engine (imap, namazu, swish-e and others -- see -;; later) by typing `G G' in the Group buffer. You will then get a -;; buffer which shows all articles matching the query, sorted by -;; Retrieval Status Value (score). - -;; When looking at the retrieval result (in the Summary buffer) you -;; can type `A W' (aka M-x gnus-warp-to-article RET) on an article. You -;; will be warped into the group this article came from. Typing `A T' -;; (aka M-x gnus-summary-refer-thread RET) will warp to the group and -;; also show the thread this article is part of. - -;; The Lisp setup may involve setting a few variables and setting up the -;; search engine. You can define the variables in the server definition -;; like this : -;; (setq gnus-secondary-select-methods '( -;; (nnimap "" (nnimap-address "localhost") -;; (nnir-search-engine namazu) -;; ))) -;; The main variable to set is `nnir-search-engine'. Choose one of -;; the engines listed in `nnir-engines'. (Actually `nnir-engines' is -;; an alist, type `C-h v nnir-engines RET' for more information; this -;; includes examples for setting `nnir-search-engine', too.) - -;; If you use one of the local indices (namazu, find-grep, swish) you -;; must also set up a search engine backend. - -;; 1. Namazu -;; -;; The Namazu backend requires you to have one directory containing all -;; index files, this is controlled by the `nnir-namazu-index-directory' -;; variable. To function the `nnir-namazu-remove-prefix' variable must -;; also be correct, see the documentation for `nnir-namazu-remove-prefix' -;; above. -;; -;; It is particularly important not to pass any switches to namazu -;; that will change the output format. Good switches to use include -;; `--sort', `--ascending', `--early' and `--late'. Refer to the Namazu -;; documentation for further information on valid switches. -;; -;; To index my mail with the `mknmz' program I use the following -;; configuration file: -;; -;; ,---- -;; | package conf; # Don't remove this line! -;; | -;; | # Paths which will not be indexed. Don't use `^' or `$' anchors. -;; | $EXCLUDE_PATH = "spam|sent"; -;; | -;; | # Header fields which should be searchable. case-insensitive -;; | $REMAIN_HEADER = "from|date|message-id|subject"; -;; | -;; | # Searchable fields. case-insensitive -;; | $SEARCH_FIELD = "from|date|message-id|subject"; -;; | -;; | # The max length of a word. -;; | $WORD_LENG_MAX = 128; -;; | -;; | # The max length of a field. -;; | $MAX_FIELD_LENGTH = 256; -;; `---- -;; -;; My mail is stored in the directories ~/Mail/mail/, ~/Mail/lists/ and -;; ~/Mail/archive/, so to index them I go to the directory set in -;; `nnir-namazu-index-directory' and issue the following command. -;; -;; mknmz --mailnews ~/Mail/archive/ ~/Mail/mail/ ~/Mail/lists/ -;; -;; For maximum searching efficiency I have a cron job set to run this -;; command every four hours. - -;; 2. find-grep -;; -;; The find-grep engine simply runs find(1) to locate eligible -;; articles and searches them with grep(1). This, of course, is much -;; slower than using a proper search engine but OTOH doesn't require -;; maintenance of an index and is still faster than using any built-in -;; means for searching. The method specification of the server to -;; search must include a directory for this engine to work (E.g., -;; `nnml-directory'). The tools must be POSIX compliant. GNU Find -;; prior to version 4.2.12 (4.2.26 on Linux due to incorrect ARG_MAX -;; handling) does not work. -;; ,---- -;; | ;; find-grep configuration for searching the Gnus Cache -;; | -;; | (nnml "cache" -;; | (nnml-get-new-mail nil) -;; | (nnir-search-engine find-grep) -;; | (nnml-directory "~/News/cache/") -;; | (nnml-active-file "~/News/cache/active")) -;; `---- - -;; Developer information: - -;; I have tried to make the code expandable. Basically, it is divided -;; into two layers. The upper layer is somewhat like the `nnvirtual' -;; backend: given a specification of what articles to show from -;; another backend, it creates a group containing exactly those -;; articles. The lower layer issues a query to a search engine and -;; produces such a specification of what articles to show from the -;; other backend. - -;; The interface between the two layers consists of the single -;; function `nnir-run-query', which dispatches the search to the -;; proper search function. The argument of `nnir-run-query' is an -;; alist with two keys: 'nnir-query-spec and 'nnir-group-spec. The -;; value for 'nnir-query-spec is an alist. The only required key/value -;; pair is (query . "query") specifying the search string to pass to -;; the query engine. Individual engines may have other elements. The -;; value of 'nnir-group-spec is a list with the specification of the -;; groups/servers to search. The format of the 'nnir-group-spec is -;; (("server1" ("group11" "group12")) ("server2" ("group21" -;; "group22"))). If any of the group lists is absent then all groups -;; on that server are searched. - -;; The output of `nnir-run-query' is supposed to be a vector, each -;; element of which should in turn be a three-element vector. The -;; first element should be full group name of the article, the second -;; element should be the article number, and the third element should -;; be the Retrieval Status Value (RSV) as returned from the search -;; engine. An RSV is the score assigned to the document by the search -;; engine. For Boolean search engines, the RSV is always 1000 (or 1 -;; or 100, or whatever you like). - -;; The sorting order of the articles in the summary buffer created by -;; nnir is based on the order of the articles in the above mentioned -;; vector, so that's where you can do the sorting you'd like. Maybe -;; it would be nice to have a way of displaying the search result -;; sorted differently? - -;; So what do you need to do when you want to add another search -;; engine? You write a function that executes the query. Temporary -;; data from the search engine can be put in `nnir-tmp-buffer'. This -;; function should return the list of articles as a vector, as -;; described above. Then, you need to register this backend in -;; `nnir-engines'. Then, users can choose the backend by setting -;; `nnir-search-engine' as a server variable. - -;;; Code: - -;;; Setup: - -(require 'nnoo) -(require 'gnus-group) -(require 'message) -(require 'gnus-util) -(eval-when-compile (require 'cl-lib)) - -;;; Internal Variables: - -(defvar nnir-memo-query nil - "Internal: stores current query.") - -(defvar nnir-memo-server nil - "Internal: stores current server.") - -(defvar nnir-artlist nil - "Internal: stores search result.") - -(defvar nnir-search-history () - "Internal: the history for querying search options in nnir.") - -(defconst nnir-tmp-buffer " *nnir*" - "Internal: temporary buffer.") - - -;; Imap variables - -(defvar nnir-imap-search-arguments - '(("whole message" . "TEXT") - ("subject" . "SUBJECT") - ("to" . "TO") - ("from" . "FROM") - ("body" . "BODY") - ("imap" . "")) - "Mapping from user readable keys to IMAP search items for use in nnir.") - -(defvar nnir-imap-search-other "HEADER %S" - "The IMAP search item to use for anything other than -`nnir-imap-search-arguments'. By default this is the name of an -email header field.") - -(defvar nnir-imap-search-argument-history () - "The history for querying search options in nnir.") - -;;; Helper macros - -;; Data type article list. - -(defmacro nnir-artlist-length (artlist) - "Return number of articles in artlist." - `(length ,artlist)) - -(defmacro nnir-artlist-article (artlist n) - "Return from ARTLIST the Nth artitem (counting starting at 1)." - `(when (> ,n 0) - (elt ,artlist (1- ,n)))) - -(defmacro nnir-artitem-group (artitem) - "Return the group from the ARTITEM." - `(elt ,artitem 0)) - -(defmacro nnir-artitem-number (artitem) - "Return the number from the ARTITEM." - `(elt ,artitem 1)) - -(defmacro nnir-artitem-rsv (artitem) - "Return the Retrieval Status Value (RSV, score) from the ARTITEM." - `(elt ,artitem 2)) - -(defmacro nnir-article-group (article) - "Return the group for ARTICLE." - `(nnir-artitem-group (nnir-artlist-article nnir-artlist ,article))) - -(defmacro nnir-article-number (article) - "Return the number for ARTICLE." - `(nnir-artitem-number (nnir-artlist-article nnir-artlist ,article))) - -(defmacro nnir-article-rsv (article) - "Return the rsv for ARTICLE." - `(nnir-artitem-rsv (nnir-artlist-article nnir-artlist ,article))) - -(defsubst nnir-article-ids (article) - "Return the pair `(nnir id . real id)' of ARTICLE." - (cons article (nnir-article-number article))) - -(defmacro nnir-categorize (sequence keyfunc &optional valuefunc) - "Sort a SEQUENCE into categories and returns a list of the form -`((key1 (element11 element12)) (key2 (element21 element22))'. -The category key for a member of the sequence is obtained -as `(KEYFUNC member)' and the corresponding element is just -`member'. If VALUEFUNC is non-nil, the element of the list -is `(VALUEFUNC member)'." - `(unless (null ,sequence) - (let (value) - (mapc - (lambda (member) - (let ((y (,keyfunc member)) - (x ,(if valuefunc - `(,valuefunc member) - 'member))) - (if (assoc y value) - (push x (cadr (assoc y value))) - (push (list y (list x)) value)))) - ,sequence) - value))) - -;;; Finish setup: - -(require 'gnus-sum) - -(nnoo-declare nnir) -(nnoo-define-basics nnir) - -(gnus-declare-backend "nnir" 'mail 'virtual) - - -;;; User Customizable Variables: - -(defgroup nnir nil - "Search groups in Gnus with assorted search engines." - :group 'gnus) - -(defcustom nnir-ignored-newsgroups "" - "A regexp to match newsgroups in the active file that should -be skipped when searching." - :version "24.1" - :type '(regexp) - :group 'nnir) - -(defcustom nnir-summary-line-format nil - "The format specification of the lines in an nnir summary buffer. - -All the items from `gnus-summary-line-format' are available, along -with three items unique to nnir summary buffers: - -%Z Search retrieval score value (integer) -%G Article original full group name (string) -%g Article original short group name (string) - -If nil this will use `gnus-summary-line-format'." - :version "24.1" - :type '(choice (const :tag "gnus-summary-line-format" nil) string) - :group 'nnir) - -(defcustom nnir-retrieve-headers-override-function nil - "If non-nil, a function that accepts an article list and group -and populates the `nntp-server-buffer' with the retrieved -headers. Must return either `nov' or `headers' indicating the -retrieved header format. - -If this variable is nil, or if the provided function returns nil for -a search result, `gnus-retrieve-headers' will be called instead." - :version "24.1" - :type '(choice (const :tag "gnus-retrieve-headers" nil) function) - :group 'nnir) - -(defcustom nnir-imap-default-search-key "whole message" - "The default IMAP search key for an nnir search. Must be one of -the keys in `nnir-imap-search-arguments'. To use raw imap queries -by default set this to \"imap\"." - :version "24.1" - :type `(choice ,@(mapcar (lambda (elem) (list 'const (car elem))) - nnir-imap-search-arguments)) - :group 'nnir) - -(defcustom nnir-swish++-configuration-file - (expand-file-name "~/Mail/swish++.conf") - "Configuration file for swish++." - :type '(file) - :group 'nnir) - -(defcustom nnir-swish++-program "search" - "Name of swish++ search executable." - :type '(string) - :group 'nnir) - -(defcustom nnir-swish++-additional-switches '() - "A list of strings, to be given as additional arguments to swish++. - -Note that this should be a list. I.e., do NOT use the following: - (setq nnir-swish++-additional-switches \"-i -w\") ; wrong -Instead, use this: - (setq nnir-swish++-additional-switches \\='(\"-i\" \"-w\"))" - :type '(repeat (string)) - :group 'nnir) - -(defcustom nnir-swish++-remove-prefix (concat (getenv "HOME") "/Mail/") - "The prefix to remove from each file name returned by swish++ -in order to get a group name (albeit with / instead of .). This is a -regular expression. - -This variable is very similar to `nnir-namazu-remove-prefix', except -that it is for swish++, not Namazu." - :type '(regexp) - :group 'nnir) - -;; Swish-E. -;; URL: http://swish-e.org/ -;; Variables `nnir-swish-e-index-file', `nnir-swish-e-program' and -;; `nnir-swish-e-additional-switches' - -(make-obsolete-variable 'nnir-swish-e-index-file - 'nnir-swish-e-index-files "Emacs 23.1") -(defcustom nnir-swish-e-index-file - (expand-file-name "~/Mail/index.swish-e") - "Index file for swish-e. -This could be a server parameter. -It is never consulted once `nnir-swish-e-index-files', which should be -used instead, has been customized." - :type '(file) - :group 'nnir) - -(defcustom nnir-swish-e-index-files - (list nnir-swish-e-index-file) - "List of index files for swish-e. -This could be a server parameter." - :type '(repeat (file)) - :group 'nnir) - -(defcustom nnir-swish-e-program "swish-e" - "Name of swish-e search executable. -This cannot be a server parameter." - :type '(string) - :group 'nnir) - -(defcustom nnir-swish-e-additional-switches '() - "A list of strings, to be given as additional arguments to swish-e. - -Note that this should be a list. I.e., do NOT use the following: - (setq nnir-swish-e-additional-switches \"-i -w\") ; wrong -Instead, use this: - (setq nnir-swish-e-additional-switches \\='(\"-i\" \"-w\")) - -This could be a server parameter." - :type '(repeat (string)) - :group 'nnir) - -(defcustom nnir-swish-e-remove-prefix (concat (getenv "HOME") "/Mail/") - "The prefix to remove from each file name returned by swish-e -in order to get a group name (albeit with / instead of .). This is a -regular expression. - -This variable is very similar to `nnir-namazu-remove-prefix', except -that it is for swish-e, not Namazu. - -This could be a server parameter." - :type '(regexp) - :group 'nnir) - -;; HyREX engine, see <URL:http://ls6-www.cs.uni-dortmund.de/> - -(defcustom nnir-hyrex-program "nnir-search" - "Name of the nnir-search executable." - :type '(string) - :group 'nnir) - -(defcustom nnir-hyrex-additional-switches '() - "A list of strings, to be given as additional arguments for nnir-search. -Note that this should be a list. I.e., do NOT use the following: - (setq nnir-hyrex-additional-switches \"-ddl ddl.xml -c nnir\") ; wrong ! -Instead, use this: - (setq nnir-hyrex-additional-switches \\='(\"-ddl\" \"ddl.xml\" \"-c\" \"nnir\"))" - :type '(repeat (string)) - :group 'nnir) - -(defcustom nnir-hyrex-index-directory (getenv "HOME") - "Index directory for HyREX." - :type '(directory) - :group 'nnir) - -(defcustom nnir-hyrex-remove-prefix (concat (getenv "HOME") "/Mail/") - "The prefix to remove from each file name returned by HyREX -in order to get a group name (albeit with / instead of .). - -For example, suppose that HyREX returns file names such as -\"/home/john/Mail/mail/misc/42\". For this example, use the following -setting: (setq nnir-hyrex-remove-prefix \"/home/john/Mail/\") -Note the trailing slash. Removing this prefix gives \"mail/misc/42\". -`nnir' knows to remove the \"/42\" and to replace \"/\" with \".\" to -arrive at the correct group name, \"mail.misc\"." - :type '(directory) - :group 'nnir) - -;; Namazu engine, see <URL:http://www.namazu.org/> - -(defcustom nnir-namazu-program "namazu" - "Name of Namazu search executable." - :type '(string) - :group 'nnir) - -(defcustom nnir-namazu-index-directory (expand-file-name "~/Mail/namazu/") - "Index directory for Namazu." - :type '(directory) - :group 'nnir) - -(defcustom nnir-namazu-additional-switches '() - "A list of strings, to be given as additional arguments to namazu. -The switches `-q', `-a', and `-s' are always used, very few other -switches make any sense in this context. - -Note that this should be a list. I.e., do NOT use the following: - (setq nnir-namazu-additional-switches \"-i -w\") ; wrong -Instead, use this: - (setq nnir-namazu-additional-switches \\='(\"-i\" \"-w\"))" - :type '(repeat (string)) - :group 'nnir) - -(defcustom nnir-namazu-remove-prefix (concat (getenv "HOME") "/Mail/") - "The prefix to remove from each file name returned by Namazu -in order to get a group name (albeit with / instead of .). - -For example, suppose that Namazu returns file names such as -\"/home/john/Mail/mail/misc/42\". For this example, use the following -setting: (setq nnir-namazu-remove-prefix \"/home/john/Mail/\") -Note the trailing slash. Removing this prefix gives \"mail/misc/42\". -`nnir' knows to remove the \"/42\" and to replace \"/\" with \".\" to -arrive at the correct group name, \"mail.misc\"." - :type '(directory) - :group 'nnir) - -(defcustom nnir-notmuch-program "notmuch" - "Name of notmuch search executable." - :version "24.1" - :type '(string) - :group 'nnir) - -(defcustom nnir-notmuch-additional-switches '() - "A list of strings, to be given as additional arguments to notmuch. - -Note that this should be a list. I.e., do NOT use the following: - (setq nnir-notmuch-additional-switches \"-i -w\") ; wrong -Instead, use this: - (setq nnir-notmuch-additional-switches \\='(\"-i\" \"-w\"))" - :version "24.1" - :type '(repeat (string)) - :group 'nnir) - -(defcustom nnir-notmuch-remove-prefix - (regexp-quote (or (getenv "MAILDIR") (expand-file-name "~/Mail"))) - "The prefix to remove from each file name returned by notmuch -in order to get a group name (albeit with / instead of .). This is a -regular expression. - -This variable is very similar to `nnir-namazu-remove-prefix', except -that it is for notmuch, not Namazu." - :version "27.1" - :type '(regexp) - :group 'nnir) - -(defcustom nnir-notmuch-filter-group-names-function nil - "Whether and how to use Gnus group names as \"path:\" search terms. -When nil, the groups being searched in are not used as notmuch -:path search terms. It's still possible to use \"path:\" terms -manually within the search query, however. - -When a function, map this function over all the group names. To -use the group names unchanged, set to (lambda (g) g). Multiple -transforms (for instance, converting \".\" to \"/\") can be added -like so: - -\(add-function :filter-return - nnir-notmuch-filter-group-names-function - (lambda (g) (replace-regexp-in-string \"\\\\.\" \"/\" g)))" - :version "27.1" - :type '(choice function - (const :tag "No" nil))) - -;;; Developer Extension Variable: - -(defvar nnir-engines - `((imap nnir-run-imap - ((criteria - "Imap Search in" ; Prompt - ,(mapcar 'car nnir-imap-search-arguments) ; alist for completing - nil ; allow any user input - nil ; initial value - nnir-imap-search-argument-history ; the history to use - ,nnir-imap-default-search-key ; default - ))) - (swish++ nnir-run-swish++ - ((swish++-group . "Swish++ Group spec (regexp): "))) - (swish-e nnir-run-swish-e - ((swish-e-group . "Swish-e Group spec (regexp): "))) - (namazu nnir-run-namazu - ()) - (notmuch nnir-run-notmuch - ()) - (hyrex nnir-run-hyrex - ((hyrex-group . "Hyrex Group spec (regexp): "))) - (find-grep nnir-run-find-grep - ((grep-options . "Grep options: ")))) - "Alist of supported search engines. -Each element in the alist is a three-element list (ENGINE FUNCTION ARGS). -ENGINE is a symbol designating the searching engine. FUNCTION is also -a symbol, giving the function that does the search. The third element -ARGS is a list of cons pairs (PARAM . PROMPT). When issuing a query, -the FUNCTION will issue a query for each of the PARAMs, using PROMPT. - -The value of `nnir-search-engine' must be one of the ENGINE symbols. -For example, for searching a server using namazu include - (nnir-search-engine namazu) -in the server definition. Note that you have to set additional -variables for most backends. For example, the `namazu' backend -needs the variables `nnir-namazu-program', -`nnir-namazu-index-directory' and `nnir-namazu-remove-prefix'. - -Add an entry here when adding a new search engine.") - -(defcustom nnir-method-default-engines '((nnimap . imap)) - "Alist of default search engines keyed by server method." - :version "27.1" - :group 'nnir - :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)) - (choice - ,@(mapcar (lambda (elem) (list 'const (car elem))) - nnir-engines))))) - -;; Gnus glue. - -(declare-function gnus-group-topic-name "gnus-topic" ()) -(declare-function gnus-topic-find-groups "gnus-topic" - (topic &optional level all lowest recursive)) - -(defun gnus-group-make-nnir-group (nnir-extra-parms &optional specs) - "Create an nnir group. -Prompt for a search query and determine the groups to search as -follows: if called from the *Server* buffer search all groups -belonging to the server on the current line; if called from the -*Group* buffer search any marked groups, or the group on the current -line, or all the groups under the current topic. Calling with a -prefix-arg prompts for additional search-engine specific constraints. -A non-nil `specs' arg must be an alist with `nnir-query-spec' and -`nnir-group-spec' keys, and skips all prompting." - (interactive "P") - (let* ((group-spec - (or (cdr (assq 'nnir-group-spec specs)) - (if (gnus-server-server-name) - (list (list (gnus-server-server-name))) - (nnir-categorize - (or gnus-group-marked - (if (gnus-group-group-name) - (list (gnus-group-group-name)) - (mapcar (lambda (entry) - (gnus-info-group (cadr entry))) - (gnus-topic-find-groups (gnus-group-topic-name))))) - gnus-group-server)))) - (query-spec - (or (cdr (assq 'nnir-query-spec specs)) - (apply - 'append - (list (cons 'query - (read-string "Query: " nil 'nnir-search-history))) - (when nnir-extra-parms - (mapcar - (lambda (x) - (nnir-read-parms (nnir-server-to-search-engine (car x)))) - group-spec)))))) - (gnus-group-read-ephemeral-group - (concat "nnir-" (message-unique-id)) - (list 'nnir "nnir") - nil -; (cons (current-buffer) gnus-current-window-configuration) - nil - nil nil - (list - (cons 'nnir-specs (list (cons 'nnir-query-spec query-spec) - (cons 'nnir-group-spec group-spec))) - (cons 'nnir-artlist nil))))) - -(defun gnus-summary-make-nnir-group (nnir-extra-parms) - "Search a group from the summary buffer." - (interactive "P") - (gnus-warp-to-article) - (let ((spec - (list - (cons 'nnir-group-spec - (list (list - (gnus-group-server gnus-newsgroup-name) - (list gnus-newsgroup-name))))))) - (gnus-group-make-nnir-group nnir-extra-parms spec))) - - -;; Gnus backend interface functions. - -(deffoo nnir-open-server (server &optional definitions) - ;; Just set the server variables appropriately. - (let ((backend (car (gnus-server-to-method server)))) - (if backend - (nnoo-change-server backend server definitions) - (add-hook 'gnus-summary-generate-hook 'nnir-mode) - (nnoo-change-server 'nnir server definitions)))) - -(deffoo nnir-request-group (group &optional server dont-check _info) - (nnir-possibly-change-group group server) - (let ((pgroup (gnus-group-guess-full-name-from-command-method group)) - length) - ;; Check for cached search result or run the query and cache the - ;; result. - (unless (and nnir-artlist dont-check) - (gnus-group-set-parameter - pgroup 'nnir-artlist - (setq nnir-artlist - (nnir-run-query - (gnus-group-get-parameter pgroup 'nnir-specs t)))) - (nnir-request-update-info pgroup (gnus-get-info pgroup))) - (with-current-buffer nntp-server-buffer - (if (zerop (setq length (nnir-artlist-length nnir-artlist))) - (progn - (nnir-close-group group) - (nnheader-report 'nnir "Search produced empty results.")) - (nnheader-insert "211 %d %d %d %s\n" - length ; total # - 1 ; first # - length ; last # - group)))) ; group name - nnir-artlist) - -(defvar gnus-inhibit-demon) - -(deffoo nnir-retrieve-headers (articles &optional _group _server _fetch-old) - (with-current-buffer nntp-server-buffer - (let ((gnus-inhibit-demon t) - (articles-by-group (nnir-categorize - articles nnir-article-group nnir-article-ids)) - headers) - (while (not (null articles-by-group)) - (let* ((group-articles (pop articles-by-group)) - (artgroup (car group-articles)) - (articleids (cadr group-articles)) - (artlist (sort (mapcar 'cdr articleids) '<)) - (server (gnus-group-server artgroup)) - (gnus-override-method (gnus-server-to-method server)) - parsefunc) - ;; (nnir-possibly-change-group nil server) - (erase-buffer) - (pcase (setq gnus-headers-retrieved-by - (or - (and - nnir-retrieve-headers-override-function - (funcall nnir-retrieve-headers-override-function - artlist artgroup)) - (gnus-retrieve-headers artlist artgroup nil))) - ('nov - (setq parsefunc 'nnheader-parse-nov)) - ('headers - (setq parsefunc 'nnheader-parse-head)) - (_ (error "Unknown header type %s while requesting articles \ - of group %s" gnus-headers-retrieved-by artgroup))) - (goto-char (point-min)) - (while (not (eobp)) - (let* ((novitem (funcall parsefunc)) - (artno (and novitem - (mail-header-number novitem))) - (art (car (rassq artno articleids)))) - (when art - (setf (mail-header-number novitem) art) - (push novitem headers)) - (forward-line 1))))) - (setq headers - (sort headers - (lambda (x y) - (< (mail-header-number x) (mail-header-number y))))) - (erase-buffer) - (mapc 'nnheader-insert-nov headers) - 'nov))) - -(defvar gnus-article-decode-hook) - -(deffoo nnir-request-article (article &optional group server to-buffer) - (nnir-possibly-change-group group server) - (if (and (stringp article) - (not (eq 'nnimap (car (gnus-server-to-method server))))) - (nnheader-report - 'nnir - "nnir-request-article only groks message ids for nnimap servers: %s" - server) - (save-excursion - (let ((article article) - query) - (when (stringp article) - (setq gnus-override-method (gnus-server-to-method server)) - (setq query - (list - (cons 'query (format "HEADER Message-ID %s" article)) - (cons 'criteria "") - (cons 'shortcut t))) - (unless (and nnir-artlist (equal query nnir-memo-query) - (equal server nnir-memo-server)) - (setq nnir-artlist (nnir-run-imap query server) - nnir-memo-query query - nnir-memo-server server)) - (setq article 1)) - (unless (zerop (nnir-artlist-length nnir-artlist)) - (let ((artfullgroup (nnir-article-group article)) - (artno (nnir-article-number article))) - (message "Requesting article %d from group %s" - artno artfullgroup) - (if to-buffer - (with-current-buffer to-buffer - (let ((gnus-article-decode-hook nil)) - (gnus-request-article-this-buffer artno artfullgroup))) - (gnus-request-article artno artfullgroup)) - (cons artfullgroup artno))))))) - -(deffoo nnir-request-move-article (article group server accept-form - &optional last _internal-move-group) - (nnir-possibly-change-group group server) - (let* ((artfullgroup (nnir-article-group article)) - (artno (nnir-article-number article)) - (to-newsgroup (nth 1 accept-form)) - (to-method (gnus-find-method-for-group to-newsgroup)) - (from-method (gnus-find-method-for-group artfullgroup)) - (move-is-internal (gnus-server-equal from-method to-method))) - (unless (gnus-check-backend-function - 'request-move-article artfullgroup) - (error "The group %s does not support article moving" artfullgroup)) - (gnus-request-move-article - artno - artfullgroup - (nth 1 from-method) - accept-form - last - (and move-is-internal - to-newsgroup ; Not respooling - (gnus-group-real-name to-newsgroup))))) - -(deffoo nnir-request-expire-articles (articles group &optional server force) - (nnir-possibly-change-group group server) - (if force - (let ((articles-by-group (nnir-categorize - articles nnir-article-group nnir-article-ids)) - not-deleted) - (while (not (null articles-by-group)) - (let* ((group-articles (pop articles-by-group)) - (artgroup (car group-articles)) - (articleids (cadr group-articles)) - (artlist (sort (mapcar 'cdr articleids) '<))) - (unless (gnus-check-backend-function 'request-expire-articles - artgroup) - (error "The group %s does not support article deletion" artgroup)) - (unless (gnus-check-server (gnus-find-method-for-group artgroup)) - (error "Couldn't open server for group %s" artgroup)) - (push (gnus-request-expire-articles - artlist artgroup force) - not-deleted))) - (sort (delq nil not-deleted) '<)) - articles)) - -(deffoo nnir-warp-to-article () - (nnir-possibly-change-group gnus-newsgroup-name) - (let* ((cur (if (> (gnus-summary-article-number) 0) - (gnus-summary-article-number) - (error "Can't warp to a pseudo-article"))) - (backend-article-group (nnir-article-group cur)) - (backend-article-number (nnir-article-number cur)) -; (quit-config (gnus-ephemeral-group-p gnus-newsgroup-name)) - ) - - ;; what should we do here? we could leave all the buffers around - ;; and assume that we have to exit from them one by one. or we can - ;; try to clean up directly - - ;;first exit from the nnir summary buffer. -; (gnus-summary-exit) - ;; and if the nnir summary buffer in turn came from another - ;; summary buffer we have to clean that summary up too. - ; (when (not (eq (cdr quit-config) 'group)) -; (gnus-summary-exit)) - (gnus-summary-read-group-1 backend-article-group t t nil - nil (list backend-article-number)))) - -(deffoo nnir-request-update-mark (_group article mark) - (let ((artgroup (nnir-article-group article)) - (artnumber (nnir-article-number article))) - (or (and artgroup - artnumber - (gnus-request-update-mark artgroup artnumber mark)) - mark))) - -(deffoo nnir-request-set-mark (group actions &optional server) - (nnir-possibly-change-group group server) - (let (mlist) - (dolist (action actions) - (cl-destructuring-bind (range action marks) action - (let ((articles-by-group (nnir-categorize - (gnus-uncompress-range range) - nnir-article-group nnir-article-number))) - (dolist (artgroup articles-by-group) - (push (list - (car artgroup) - (list (gnus-compress-sequence - (sort (cadr artgroup) '<)) - action marks)) - mlist))))) - (dolist (request (nnir-categorize mlist car cadr)) - (gnus-request-set-mark (car request) (cadr request))))) - - -(deffoo nnir-request-update-info (group info &optional server) - (nnir-possibly-change-group group server) - ;; clear out all existing marks. - (setf (gnus-info-marks info) nil) - (setf (gnus-info-read info) nil) - (let ((group (gnus-group-guess-full-name-from-command-method group)) - (articles-by-group - (nnir-categorize - (gnus-uncompress-range (cons 1 (nnir-artlist-length nnir-artlist))) - nnir-article-group nnir-article-ids))) - (gnus-set-active group - (cons 1 (nnir-artlist-length nnir-artlist))) - (while (not (null articles-by-group)) - (let* ((group-articles (pop articles-by-group)) - (articleids (reverse (cadr group-articles))) - (group-info (gnus-get-info (car group-articles))) - (marks (gnus-info-marks group-info)) - (read (gnus-info-read group-info))) - (setf (gnus-info-read info) - (gnus-add-to-range - (gnus-info-read info) - (delq nil - (mapcar - #'(lambda (art) - (when (gnus-member-of-range (cdr art) read) - (car art))) - articleids)))) - (dolist (mark marks) - (cl-destructuring-bind (type . range) mark - (gnus-add-marked-articles - group type - (delq nil - (mapcar - #'(lambda (art) - (when (gnus-member-of-range (cdr art) range) (car art))) - articleids))))))))) - - -(deffoo nnir-close-group (group &optional server) - (nnir-possibly-change-group group server) - (let ((pgroup (gnus-group-guess-full-name-from-command-method group))) - (when (and nnir-artlist (not (gnus-ephemeral-group-p pgroup))) - (gnus-group-set-parameter pgroup 'nnir-artlist nnir-artlist)) - (setq nnir-artlist nil) - (when (gnus-ephemeral-group-p pgroup) - (gnus-kill-ephemeral-group pgroup) - (setq gnus-ephemeral-servers - (delq (assq 'nnir gnus-ephemeral-servers) - gnus-ephemeral-servers))))) -;; (gnus-opened-servers-remove -;; (car (assoc '(nnir "nnir-ephemeral" (nnir-address "nnir")) -;; gnus-opened-servers)))) - - - - -(defmacro nnir-add-result (dirnam artno score prefix server artlist) - "Ask `nnir-compose-result' to construct a result vector, -and if it is non-nil, add it to ARTLIST." - `(let ((result (nnir-compose-result ,dirnam ,artno ,score ,prefix ,server))) - (when (not (null result)) - (push result ,artlist)))) - -(autoload 'nnmaildir-base-name-to-article-number "nnmaildir") - -;; Helper function currently used by the Swish++ and Namazu backends; -;; perhaps useful for other backends as well -(defun nnir-compose-result (dirnam article score prefix server) - "Extract the group from DIRNAM, and create a result vector -ready to be added to the list of search results." - - ;; remove nnir-*-remove-prefix from beginning of dirnam filename - (when (string-match (concat "^" prefix) dirnam) - (setq dirnam (replace-match "" t t dirnam))) - - (when (file-readable-p (concat prefix dirnam article)) - ;; remove trailing slash and, for nnmaildir, cur/new/tmp - (setq dirnam - (substring dirnam 0 - (if (string-match "\\`nnmaildir:" (gnus-group-server server)) - -5 -1))) - - ;; Set group to dirnam without any leading dots or slashes, - ;; and with all subsequent slashes replaced by dots - (let ((group (replace-regexp-in-string - "[/\\]" "." - (replace-regexp-in-string "^[./\\]" "" dirnam nil t) - nil t))) - - (vector (gnus-group-full-name group server) - (if (string-match "\\`nnmaildir:" (gnus-group-server server)) - (nnmaildir-base-name-to-article-number - (substring article 0 (string-match ":" article)) - group nil) - (string-to-number article)) - (string-to-number score))))) - -;;; Search Engine Interfaces: - -(autoload 'nnimap-change-group "nnimap") -(declare-function nnimap-buffer "nnimap" ()) -(declare-function nnimap-command "nnimap" (&rest args)) - -;; imap interface -(defun nnir-run-imap (query srv &optional groups) - "Run a search against an IMAP back-end server. -This uses a custom query language parser; see `nnir-imap-make-query' -for details on the language and supported extensions." - (save-excursion - (let ((qstring (cdr (assq 'query query))) - (server (cadr (gnus-server-to-method srv))) -;; (defs (nth 2 (gnus-server-to-method srv))) - (criteria (or (cdr (assq 'criteria query)) - (cdr (assoc nnir-imap-default-search-key - nnir-imap-search-arguments)))) - (gnus-inhibit-demon t) - (groups (or groups (nnir-get-active srv)))) - (message "Opening server %s" server) - (apply - 'vconcat - (catch 'found - (mapcar - #'(lambda (group) - (let (artlist) - (condition-case () - (when (nnimap-change-group - (gnus-group-short-name group) server) - (with-current-buffer (nnimap-buffer) - (message "Searching %s..." group) - (let ((arts 0) - (result (nnimap-command "UID SEARCH %s" - (if (string= criteria "") - qstring - (nnir-imap-make-query - criteria qstring))))) - (mapc - (lambda (artnum) - (let ((artn (string-to-number artnum))) - (when (> artn 0) - (push (vector group artn 100) - artlist) - (when (assq 'shortcut query) - (throw 'found (list artlist))) - (setq arts (1+ arts))))) - (and (car result) - (cdr (assoc "SEARCH" (cdr result))))) - (message "Searching %s... %d matches" group arts))) - (message "Searching %s...done" group)) - (quit nil)) - (nreverse artlist))) - groups)))))) - -(defun nnir-imap-make-query (criteria qstring) - "Parse the query string and criteria into an appropriate IMAP search -expression, returning the string query to make. - -This implements a little language designed to return the expected -results to an arbitrary query string to the end user. - -The search is always case-insensitive, as defined by RFC2060, and -supports the following features (inspired by the Google search input -language): - -Automatic \"and\" queries - If you specify multiple words then they will be treated as an - \"and\" expression intended to match all components. - -Phrase searches - If you wrap your query in double-quotes then it will be treated - as a literal string. - -Negative terms - If you precede a term with \"-\" then it will negate that. - -\"OR\" queries - If you include an upper-case \"OR\" in your search it will cause - the term before it and the term after it to be treated as - alternatives. - -In the future the following will be added to the language: - * support for date matches - * support for location of text matching within the query - * from/to/etc headers - * additional search terms - * flag based searching - * anything else that the RFC supports, basically." - ;; Walk through the query and turn it into an IMAP query string. - (nnir-imap-query-to-imap criteria (nnir-imap-parse-query qstring))) - - -(defun nnir-imap-query-to-imap (criteria query) - "Turn an s-expression format QUERY into IMAP." - (mapconcat - ;; Turn the expressions into IMAP text - (lambda (item) - (nnir-imap-expr-to-imap criteria item)) - ;; The query, already in s-expr format. - query - ;; Append a space between each expression - " ")) - - -(defun nnir-imap-expr-to-imap (criteria expr) - "Convert EXPR into an IMAP search expression on CRITERIA." - ;; What sort of expression is this, eh? - (cond - ;; Simple string term - ((stringp expr) - (format "%s %S" criteria expr)) - ;; Trivial term: and - ((eq expr 'and) nil) - ;; Composite term: or expression - ((eq (car-safe expr) 'or) - (format "OR %s %s" - (nnir-imap-expr-to-imap criteria (nth 1 expr)) - (nnir-imap-expr-to-imap criteria (nth 2 expr)))) - ;; Composite term: just the fax, mam - ((eq (car-safe expr) 'not) - (format "NOT (%s)" (nnir-imap-query-to-imap criteria (cdr expr)))) - ;; Composite term: just expand it all. - ((consp expr) - (format "(%s)" (nnir-imap-query-to-imap criteria expr))) - ;; Complex value, give up for now. - (t (error "Unhandled input: %S" expr)))) - - -(defun nnir-imap-parse-query (string) - "Turn STRING into an s-expression based query based on the IMAP -query language as defined in `nnir-imap-make-query'. - -This involves turning individual tokens into higher level terms -that the search language can then understand and use." - (with-temp-buffer - ;; Set up the parsing environment. - (insert string) - (goto-char (point-min)) - ;; Now, collect the output terms and return them. - (let (out) - (while (not (nnir-imap-end-of-input)) - (push (nnir-imap-next-expr) out)) - (reverse out)))) - - -(defun nnir-imap-next-expr (&optional count) - "Return the next expression from the current buffer." - (let ((term (nnir-imap-next-term count)) - (next (nnir-imap-peek-symbol))) - ;; Are we looking at an 'or' expression? - (cond - ;; Handle 'expr or expr' - ((eq next 'or) - (list 'or term (nnir-imap-next-expr 2))) - ;; Anything else - (t term)))) - - -(defun nnir-imap-next-term (&optional count) - "Return the next term from the current buffer." - (let ((term (nnir-imap-next-symbol count))) - ;; What sort of term is this? - (cond - ;; and -- just ignore it - ((eq term 'and) 'and) - ;; negated term - ((eq term 'not) (list 'not (nnir-imap-next-expr))) - ;; generic term - (t term)))) - - -(defun nnir-imap-peek-symbol () - "Return the next symbol from the current buffer, but don't consume it." - (save-excursion - (nnir-imap-next-symbol))) - -(defun nnir-imap-next-symbol (&optional count) - "Return the next symbol from the current buffer, or nil if we are -at the end of the buffer. If supplied COUNT skips some symbols before -returning the one at the supplied position." - (when (and (numberp count) (> count 1)) - (nnir-imap-next-symbol (1- count))) - (let ((case-fold-search t)) - ;; end of input stream? - (unless (nnir-imap-end-of-input) - ;; No, return the next symbol from the stream. - (cond - ;; negated expression -- return it and advance one char. - ((looking-at "-") (forward-char 1) 'not) - ;; quoted string - ((looking-at "\"") (nnir-imap-delimited-string "\"")) - ;; list expression -- we parse the content and return this as a list. - ((looking-at "(") - (nnir-imap-parse-query (nnir-imap-delimited-string ")"))) - ;; keyword input -- return a symbol version - ((looking-at "\\band\\b") (forward-char 3) 'and) - ((looking-at "\\bor\\b") (forward-char 2) 'or) - ((looking-at "\\bnot\\b") (forward-char 3) 'not) - ;; Simple, boring keyword - (t (let ((start (point)) - (end (if (search-forward-regexp "[[:blank:]]" nil t) - (prog1 - (match-beginning 0) - ;; unskip if we hit a non-blank terminal character. - (when (string-match "[^[:blank:]]" (match-string 0)) - (backward-char 1))) - (goto-char (point-max))))) - (buffer-substring start end))))))) - -(defun nnir-imap-delimited-string (delimiter) - "Return a delimited string from the current buffer." - (let ((start (point)) end) - (forward-char 1) ; skip the first delimiter. - (while (not end) - (unless (search-forward delimiter nil t) - (error "Unmatched delimited input with %s in query" delimiter)) - (let ((here (point))) - (unless (equal (buffer-substring (- here 2) (- here 1)) "\\") - (setq end (point))))) - (buffer-substring (1+ start) (1- end)))) - -(defun nnir-imap-end-of-input () - "Are we at the end of input?" - (skip-chars-forward "[:blank:]") - (looking-at "$")) - - -;; Swish++ interface. -;; -cc- Todo -;; Search by -;; - group -;; Sort by -;; - rank (default) -;; - article number -;; - file size -;; - group -(defun nnir-run-swish++ (query server &optional _group) - "Run QUERY against swish++. -Returns a vector of (group name, file name) pairs (also vectors, -actually). - -Tested with swish++ 4.7 on GNU/Linux and with swish++ 5.0b2 on -Windows NT 4.0." - - ;; (when group - ;; (error "The swish++ backend cannot search specific groups")) - - (save-excursion - (let ( (qstring (cdr (assq 'query query))) - (groupspec (cdr (assq 'swish++-group query))) - (prefix (nnir-read-server-parm 'nnir-swish++-remove-prefix server)) - artlist - ;; nnml-use-compressed-files might be any string, but probably this - ;; is sufficient. Note that we can't only use the value of - ;; nnml-use-compressed-files because old articles might have been - ;; saved with a different value. - (article-pattern (if (string-match "\\`nnmaildir:" - (gnus-group-server server)) - ":[0-9]+" - "^[0-9]+\\(\\.[a-z0-9]+\\)?$")) - score artno dirnam filenam) - - (when (equal "" qstring) - (error "swish++: You didn't enter anything")) - - (set-buffer (get-buffer-create nnir-tmp-buffer)) - (erase-buffer) - - (if groupspec - (message "Doing swish++ query %s on %s..." qstring groupspec) - (message "Doing swish++ query %s..." qstring)) - - (let* ((cp-list `( ,nnir-swish++-program - nil ; input from /dev/null - t ; output - nil ; don't redisplay - "--config-file" ,(nnir-read-server-parm 'nnir-swish++-configuration-file server) - ,@(nnir-read-server-parm 'nnir-swish++-additional-switches server) - ,qstring ; the query, in swish++ format - )) - (exitstatus - (progn - (message "%s args: %s" nnir-swish++-program - (mapconcat #'identity (nthcdr 4 cp-list) " ")) ;; ??? - (apply #'call-process cp-list)))) - (unless (or (null exitstatus) - (zerop exitstatus)) - (nnheader-report 'nnir "Couldn't run swish++: %s" exitstatus) - ;; swish++ failure reason is in this buffer, show it if - ;; the user wants it. - (when (> gnus-verbose 6) - (display-buffer nnir-tmp-buffer)))) - - ;; The results are output in the format of: - ;; V 4.7 Linux - ;; rank relative-path-name file-size file-title - ;; V 5.0b2: - ;; rank relative-path-name file-size topic?? - ;; where rank is an integer from 1 to 100. - (goto-char (point-min)) - (while (re-search-forward - "\\(^[0-9]+\\) \\([^ ]+\\) [0-9]+ \\(.*\\)$" nil t) - (setq score (match-string 1) - filenam (match-string 2) - artno (file-name-nondirectory filenam) - dirnam (file-name-directory filenam)) - - ;; don't match directories - (when (string-match article-pattern artno) - (when (not (null dirnam)) - - ;; maybe limit results to matching groups. - (when (or (not groupspec) - (string-match groupspec dirnam)) - (nnir-add-result dirnam artno score prefix server artlist))))) - - (message "Massaging swish++ output...done") - - ;; Sort by score - (apply #'vector - (sort artlist - (function (lambda (x y) - (> (nnir-artitem-rsv x) - (nnir-artitem-rsv y))))))))) - -;; Swish-E interface. -(defun nnir-run-swish-e (query server &optional _group) - "Run given QUERY against swish-e. -Returns a vector of (group name, file name) pairs (also vectors, -actually). - -Tested with swish-e-2.0.1 on Windows NT 4.0." - - ;; swish-e crashes with empty parameter to "-w" on commandline... - ;; (when group - ;; (error "The swish-e backend cannot search specific groups")) - - (save-excursion - (let ((qstring (cdr (assq 'query query))) - (prefix - (or (nnir-read-server-parm 'nnir-swish-e-remove-prefix server) - (error "Missing parameter `nnir-swish-e-remove-prefix'"))) - artlist score artno dirnam group ) - - (when (equal "" qstring) - (error "swish-e: You didn't enter anything")) - - (set-buffer (get-buffer-create nnir-tmp-buffer)) - (erase-buffer) - - (message "Doing swish-e query %s..." query) - (let* ((index-files - (or (nnir-read-server-parm - 'nnir-swish-e-index-files server) - (error "Missing parameter `nnir-swish-e-index-files'"))) - (additional-switches - (nnir-read-server-parm - 'nnir-swish-e-additional-switches server)) - (cp-list `(,nnir-swish-e-program - nil ; input from /dev/null - t ; output - nil ; don't redisplay - "-f" ,@index-files - ,@additional-switches - "-w" - ,qstring ; the query, in swish-e format - )) - (exitstatus - (progn - (message "%s args: %s" nnir-swish-e-program - (mapconcat #'identity (nthcdr 4 cp-list) " ")) - (apply #'call-process cp-list)))) - (unless (or (null exitstatus) - (zerop exitstatus)) - (nnheader-report 'nnir "Couldn't run swish-e: %s" exitstatus) - ;; swish-e failure reason is in this buffer, show it if - ;; the user wants it. - (when (> gnus-verbose 6) - (display-buffer nnir-tmp-buffer)))) - - ;; The results are output in the format of: - ;; rank path-name file-title file-size - (goto-char (point-min)) - (while (re-search-forward - "\\(^[0-9]+\\) \\([^ ]+\\) \"\\([^\"]+\\)\" [0-9]+$" nil t) - (setq score (match-string 1) - artno (match-string 3) - dirnam (file-name-directory (match-string 2))) - - ;; don't match directories - (when (string-match "^[0-9]+$" artno) - (when (not (null dirnam)) - - ;; remove nnir-swish-e-remove-prefix from beginning of dirname - (when (string-match (concat "^" prefix) dirnam) - (setq dirnam (replace-match "" t t dirnam))) - - (setq dirnam (substring dirnam 0 -1)) - ;; eliminate all ".", "/", "\" from beginning. Always matches. - (string-match "^[./\\]*\\(.*\\)$" dirnam) - ;; "/" -> "." - (setq group (replace-regexp-in-string - "/" "." (match-string 1 dirnam))) - ;; Windows "\\" -> "." - (setq group (replace-regexp-in-string "\\\\" "." group)) - - (push (vector (gnus-group-full-name group server) - (string-to-number artno) - (string-to-number score)) - artlist)))) - - (message "Massaging swish-e output...done") - - ;; Sort by score - (apply #'vector - (sort artlist - (function (lambda (x y) - (> (nnir-artitem-rsv x) - (nnir-artitem-rsv y))))))))) - -;; HyREX interface -(defun nnir-run-hyrex (query server &optional group) - (save-excursion - (let ((artlist nil) - (groupspec (cdr (assq 'hyrex-group query))) - (qstring (cdr (assq 'query query))) - (prefix (nnir-read-server-parm 'nnir-hyrex-remove-prefix server)) - score artno dirnam) - (when (and (not groupspec) group) - (setq groupspec - (regexp-opt - (mapcar (lambda (x) (gnus-group-real-name x)) group)))) - (set-buffer (get-buffer-create nnir-tmp-buffer)) - (erase-buffer) - (message "Doing hyrex-search query %s..." query) - (let* ((cp-list - `( ,nnir-hyrex-program - nil ; input from /dev/null - t ; output - nil ; don't redisplay - "-i",(nnir-read-server-parm 'nnir-hyrex-index-directory server) ; index directory - ,@(nnir-read-server-parm 'nnir-hyrex-additional-switches server) - ,qstring ; the query, in hyrex-search format - )) - (exitstatus - (progn - (message "%s args: %s" nnir-hyrex-program - (mapconcat #'identity (nthcdr 4 cp-list) " ")) - (apply #'call-process cp-list)))) - (unless (or (null exitstatus) - (zerop exitstatus)) - (nnheader-report 'nnir "Couldn't run hyrex-search: %s" exitstatus) - ;; nnir-search failure reason is in this buffer, show it if - ;; the user wants it. - (when (> gnus-verbose 6) - (display-buffer nnir-tmp-buffer)))) ;; FIXME: Don't clear buffer ! - (message "Doing hyrex-search query \"%s\"...done" qstring) - (sit-for 0) - ;; nnir-search returns: - ;; for nnml/nnfolder: "filename mailid weight" - ;; for nnimap: "group mailid weight" - (goto-char (point-min)) - (delete-non-matching-lines "^\\S + [0-9]+ [0-9]+$") - ;; HyREX doesn't search directly in groups -- so filter out here. - (when groupspec - (keep-lines groupspec)) - ;; extract data from result lines - (goto-char (point-min)) - (while (re-search-forward - "\\(\\S +\\) \\([0-9]+\\) \\([0-9]+\\)" nil t) - (setq dirnam (match-string 1) - artno (match-string 2) - score (match-string 3)) - (when (string-match prefix dirnam) - (setq dirnam (replace-match "" t t dirnam))) - (push (vector (gnus-group-full-name - (replace-regexp-in-string "/" "." dirnam) server) - (string-to-number artno) - (string-to-number score)) - artlist)) - (message "Massaging hyrex-search output...done.") - (apply #'vector - (sort artlist - (function (lambda (x y) - (if (string-lessp (nnir-artitem-group x) - (nnir-artitem-group y)) - t - (< (nnir-artitem-number x) - (nnir-artitem-number y))))))) - ))) - -;; Namazu interface -(defun nnir-run-namazu (query server &optional _group) - "Run given QUERY against Namazu. -Returns a vector of (group name, file name) pairs (also vectors, -actually). - -Tested with Namazu 2.0.6 on a GNU/Linux system." - ;; (when group - ;; (error "The Namazu backend cannot search specific groups")) - (save-excursion - (let ((article-pattern (if (string-match "\\`nnmaildir:" - (gnus-group-server server)) - ":[0-9]+" - "^[0-9]+$")) - artlist - (qstring (cdr (assq 'query query))) - (prefix (nnir-read-server-parm 'nnir-namazu-remove-prefix server)) - score group article - (process-environment (copy-sequence process-environment))) - (setenv "LC_MESSAGES" "C") - (set-buffer (get-buffer-create nnir-tmp-buffer)) - (erase-buffer) - (let* ((cp-list - `( ,nnir-namazu-program - nil ; input from /dev/null - t ; output - nil ; don't redisplay - "-q" ; don't be verbose - "-a" ; show all matches - "-s" ; use short format - ,@(nnir-read-server-parm 'nnir-namazu-additional-switches server) - ,qstring ; the query, in namazu format - ,(nnir-read-server-parm 'nnir-namazu-index-directory server) ; index directory - )) - (exitstatus - (progn - (message "%s args: %s" nnir-namazu-program - (mapconcat #'identity (nthcdr 4 cp-list) " ")) - (apply #'call-process cp-list)))) - (unless (or (null exitstatus) - (zerop exitstatus)) - (nnheader-report 'nnir "Couldn't run namazu: %s" exitstatus) - ;; Namazu failure reason is in this buffer, show it if - ;; the user wants it. - (when (> gnus-verbose 6) - (display-buffer nnir-tmp-buffer)))) - - ;; Namazu output looks something like this: - ;; 2. Re: Gnus agent expire broken (score: 55) - ;; /home/henrik/Mail/mail/sent/1310 (4,138 bytes) - - (goto-char (point-min)) - (while (re-search-forward - "^\\([0-9,]+\\.\\).*\\((score: \\([0-9]+\\)\\))\n\\([^ ]+\\)" - nil t) - (setq score (match-string 3) - group (file-name-directory (match-string 4)) - article (file-name-nondirectory (match-string 4))) - - ;; make sure article and group is sane - (when (and (string-match article-pattern article) - (not (null group))) - (nnir-add-result group article score prefix server artlist))) - - ;; sort artlist by score - (apply #'vector - (sort artlist - (function (lambda (x y) - (> (nnir-artitem-rsv x) - (nnir-artitem-rsv y))))))))) - -(defun nnir-run-notmuch (query server &optional groups) - "Run QUERY against notmuch. -Returns a vector of (group name, file name) pairs (also vectors, -actually). If GROUPS is a list of group names, use them to -construct path: search terms (see the variable -`nnir-notmuch-filter-group-names-function')." - - (save-excursion - (let* ((qstring (cdr (assq 'query query))) - (prefix (nnir-read-server-parm 'nnir-notmuch-remove-prefix server)) - artlist - (article-pattern (if (string-match "\\`nnmaildir:" - (gnus-group-server server)) - ":[0-9]+" - "^[0-9]+$")) - (groups (when nnir-notmuch-filter-group-names-function - (delq nil - (mapcar nnir-notmuch-filter-group-names-function - (mapcar #'gnus-group-short-name groups))))) - (pathquery (when groups - (concat " (" - (mapconcat (lambda (g) - (format "path:%s" g)) - groups " or") - ")"))) - artno dirnam filenam) - - (when (equal "" qstring) - (error "notmuch: You didn't enter anything")) - - (set-buffer (get-buffer-create nnir-tmp-buffer)) - (erase-buffer) - - (if groups - (message "Doing notmuch query %s on %s..." - qstring (mapconcat #'identity groups " ")) - (message "Doing notmuch query %s..." qstring)) - - (when groups - (setq qstring (concat qstring pathquery))) - - (let* ((cp-list `( ,nnir-notmuch-program - nil ; input from /dev/null - t ; output - nil ; don't redisplay - "search" - "--format=text" - "--output=files" - ,@(nnir-read-server-parm 'nnir-notmuch-additional-switches server) - ,qstring ; the query, in notmuch format - )) - (exitstatus - (progn - (message "%s args: %s" nnir-notmuch-program - (mapconcat #'identity (nthcdr 4 cp-list) " ")) ;; ??? - (apply #'call-process cp-list)))) - (unless (or (null exitstatus) - (zerop exitstatus)) - (nnheader-report 'nnir "Couldn't run notmuch: %s" exitstatus) - ;; notmuch failure reason is in this buffer, show it if - ;; the user wants it. - (when (> gnus-verbose 6) - (display-buffer nnir-tmp-buffer)))) - - ;; The results are output in the format of: - ;; absolute-path-name - (goto-char (point-min)) - (while (not (eobp)) - (setq filenam (buffer-substring-no-properties (line-beginning-position) - (line-end-position)) - artno (file-name-nondirectory filenam) - dirnam (file-name-directory filenam)) - (forward-line 1) - - ;; don't match directories - (when (string-match article-pattern artno) - (when (not (null dirnam)) - - (nnir-add-result dirnam artno "" prefix server artlist)))) - - (message "Massaging notmuch output...done") - - artlist))) - -(defun nnir-run-find-grep (query server &optional grouplist) - "Run find and grep to obtain matching articles." - (let* ((method (gnus-server-to-method server)) - (sym (intern - (concat (symbol-name (car method)) "-directory"))) - (directory (cadr (assoc sym (cddr method)))) - (regexp (cdr (assoc 'query query))) - (grep-options (cdr (assoc 'grep-options query))) - (grouplist (or grouplist (nnir-get-active server)))) - (unless directory - (error "No directory found in method specification of server %s" - server)) - (apply - 'vconcat - (mapcar (lambda (x) - (let ((group x) - artlist) - (message "Searching %s using find-grep..." - (or group server)) - (save-window-excursion - (set-buffer (get-buffer-create nnir-tmp-buffer)) - (if (> gnus-verbose 6) - (pop-to-buffer (current-buffer))) - (cd directory) ; Using relative paths simplifies - ; postprocessing. - (let ((group - (if (not group) - "." - ;; Try accessing the group literally as - ;; well as interpreting dots as directory - ;; separators so the engine works with - ;; plain nnml as well as the Gnus Cache. - (let ((group (gnus-group-real-name group))) - ;; Replace cl-func find-if. - (if (file-directory-p group) - group - (if (file-directory-p - (setq group - (replace-regexp-in-string - "\\." "/" - group nil t))) - group)))))) - (unless group - (error "Cannot locate directory for group")) - (save-excursion - (apply - 'call-process "find" nil t - "find" group "-maxdepth" "1" "-type" "f" - "-name" "[0-9]*" "-exec" - "grep" - `("-l" ,@(and grep-options - (split-string grep-options "\\s-" t)) - "-e" ,regexp "{}" "+")))) - - ;; Translate relative paths to group names. - (while (not (eobp)) - (let* ((path (split-string - (buffer-substring - (point) - (line-end-position)) "/" t)) - (art (string-to-number (car (last path))))) - (while (string= "." (car path)) - (setq path (cdr path))) - (let ((group (mapconcat #'identity - ;; Replace cl-func: - ;; (subseq path 0 -1) - (let ((end (1- (length path))) - res) - (while - (>= (setq end (1- end)) 0) - (push (pop path) res)) - (nreverse res)) - "."))) - (push - (vector (gnus-group-full-name group server) art 0) - artlist)) - (forward-line 1))) - (message "Searching %s using find-grep...done" - (or group server)) - artlist))) - grouplist)))) - -(declare-function mm-url-insert "mm-url" (url &optional follow-refresh)) -(declare-function mm-url-encode-www-form-urlencoded "mm-url" (pairs)) - -;;; Util Code: - -(defun gnus-nnir-group-p (group) - "Say whether GROUP is nnir or not." - (if (gnus-group-prefixed-p group) - (eq 'nnir (car (gnus-find-method-for-group group))) - (and group (string-match "^nnir" group)))) - -(defun nnir-read-parms (nnir-search-engine) - "Read additional search parameters according to `nnir-engines'." - (let ((parmspec (nth 2 (assoc nnir-search-engine nnir-engines)))) - (mapcar #'nnir-read-parm parmspec))) - -(defun nnir-read-parm (parmspec) - "Read a single search parameter. -PARMSPEC is a cons cell, the car is a symbol, the cdr is a prompt." - (let ((sym (car parmspec)) - (prompt (cdr parmspec))) - (if (listp prompt) - (let* ((result (apply #'gnus-completing-read prompt)) - (mapping (or (assoc result nnir-imap-search-arguments) - (cons nil nnir-imap-search-other)))) - (cons sym (format (cdr mapping) result))) - (cons sym (read-string prompt))))) - -(defun nnir-run-query (specs) - "Invoke appropriate search engine function (see `nnir-engines')." - (apply #'vconcat - (mapcar - (lambda (x) - (let* ((server (car x)) - (search-engine (nnir-server-to-search-engine server)) - (search-func (cadr (assoc search-engine nnir-engines)))) - (and search-func - (funcall search-func (cdr (assq 'nnir-query-spec specs)) - server (cadr x))))) - (cdr (assq 'nnir-group-spec specs))))) - -(defun nnir-server-to-search-engine (server) - (or (nnir-read-server-parm 'nnir-search-engine server t) - (cdr (assoc (car (gnus-server-to-method server)) - nnir-method-default-engines)))) - -(defun nnir-read-server-parm (key server &optional not-global) - "Return the parameter value corresponding to KEY for SERVER. -If no server-specific value is found consult the global -environment unless NOT-GLOBAL is non-nil." - (let ((method (gnus-server-to-method server))) - (cond ((and method (assq key (cddr method))) - (nth 1 (assq key (cddr method)))) - ((and (not not-global) (boundp key)) (symbol-value key)) - (t nil)))) - -(defun nnir-possibly-change-group (group &optional server) - (or (not server) (nnir-server-opened server) (nnir-open-server server)) - (when (gnus-nnir-group-p group) - (setq nnir-artlist (gnus-group-get-parameter - (gnus-group-prefixed-name - (gnus-group-short-name group) '(nnir "nnir")) - 'nnir-artlist t)))) - -(defun nnir-server-opened (&optional server) - (let ((backend (car (gnus-server-to-method server)))) - (nnoo-current-server-p (or backend 'nnir) server))) - -(autoload 'nnimap-make-thread-query "nnimap") -(declare-function gnus-registry-get-id-key "gnus-registry" (id key)) - -(defun nnir-search-thread (header) - "Make an nnir group based on the thread containing the article HEADER. -The current server will be searched. If the registry is installed, -the server that the registry reports the current article came from -is also searched." - (let* ((query - (list (cons 'query (nnimap-make-thread-query header)) - (cons 'criteria ""))) - (server - (list (list (gnus-method-to-server - (gnus-find-method-for-group gnus-newsgroup-name))))) - (registry-group (and - (bound-and-true-p gnus-registry-enabled) - (car (gnus-registry-get-id-key - (mail-header-id header) 'group)))) - (registry-server - (and registry-group - (gnus-method-to-server - (gnus-find-method-for-group registry-group))))) - (when registry-server - (cl-pushnew (list registry-server) server :test #'equal)) - (gnus-group-make-nnir-group nil (list - (cons 'nnir-query-spec query) - (cons 'nnir-group-spec server))) - (gnus-summary-goto-subject (gnus-id-to-article (mail-header-id header))))) - -(defun nnir-get-active (srv) - (let ((method (gnus-server-to-method srv)) - groups) - (gnus-request-list method) - (with-current-buffer nntp-server-buffer - (let ((cur (current-buffer))) - (goto-char (point-min)) - (unless (or (null nnir-ignored-newsgroups) - (string= nnir-ignored-newsgroups "")) - (delete-matching-lines nnir-ignored-newsgroups)) - (if (eq (car method) 'nntp) - (while (not (eobp)) - (ignore-errors - (push (gnus-group-full-name - (buffer-substring - (point) - (progn - (skip-chars-forward "^ \t") - (point))) - method) - groups)) - (forward-line)) - (while (not (eobp)) - (ignore-errors - (push (if (eq (char-after) ?\") - (gnus-group-full-name (read cur) method) - (let ((p (point)) (name "")) - (skip-chars-forward "^ \t\\\\") - (setq name (buffer-substring p (point))) - (while (eq (char-after) ?\\) - (setq p (1+ (point))) - (forward-char 2) - (skip-chars-forward "^ \t\\\\") - (setq name (concat name (buffer-substring - p (point))))) - (gnus-group-full-name name method))) - groups)) - (forward-line))))) - groups)) - -;; Behind gnus-registry-enabled test. -(declare-function gnus-registry-action "gnus-registry" - (action data-header from &optional to method)) - -(defun nnir-registry-action (action data-header _from &optional to method) - "Call `gnus-registry-action' with the original article group." - (gnus-registry-action - action - data-header - (nnir-article-group (mail-header-number data-header)) - to - method)) - -(defun nnir-mode () - (when (eq (car (gnus-find-method-for-group gnus-newsgroup-name)) 'nnir) - (when (and nnir-summary-line-format - (not (string= nnir-summary-line-format - gnus-summary-line-format))) - (setq gnus-summary-line-format nnir-summary-line-format) - (gnus-update-format-specifications nil 'summary)) - (when (bound-and-true-p gnus-registry-enabled) - (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action t) - (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action t) - (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action t) - (add-hook 'gnus-summary-article-delete-hook 'nnir-registry-action t t) - (add-hook 'gnus-summary-article-move-hook 'nnir-registry-action t t) - (add-hook 'gnus-summary-article-expire-hook 'nnir-registry-action t t)))) - - -(defun gnus-summary-create-nnir-group () - (interactive) - (or (nnir-server-opened "") (nnir-open-server "nnir")) - (let ((name (gnus-read-group "Group name: ")) - (method '(nnir "")) - (pgroup - (gnus-group-guess-full-name-from-command-method gnus-newsgroup-name))) - (with-current-buffer gnus-group-buffer - (gnus-group-make-group - name method nil - (gnus-group-find-parameter pgroup))))) - - -(deffoo nnir-request-create-group (group &optional _server args) - (message "Creating nnir group %s" group) - (let* ((group (gnus-group-prefixed-name group '(nnir "nnir"))) - (specs (assq 'nnir-specs args)) - (query-spec - (or (cdr (assq 'nnir-query-spec specs)) - (list (cons 'query - (read-string "Query: " nil 'nnir-search-history))))) - (group-spec - (or (cdr (assq 'nnir-group-spec specs)) - (list (list (read-string "Server: " nil nil))))) - (nnir-specs (list (cons 'nnir-query-spec query-spec) - (cons 'nnir-group-spec group-spec)))) - (gnus-group-set-parameter group 'nnir-specs nnir-specs) - (gnus-group-set-parameter - group 'nnir-artlist - (or (cdr (assq 'nnir-artlist args)) - (nnir-run-query nnir-specs))) - (nnir-request-update-info group (gnus-get-info group))) - t) - -(deffoo nnir-request-delete-group (_group &optional _force _server) - t) - -(deffoo nnir-request-list (&optional _server) - t) - -(deffoo nnir-request-scan (_group _method) - t) - -(deffoo nnir-request-close () - t) - -(nnoo-define-skeleton nnir) - -;; The end. -(provide 'nnir) - -;;; nnir.el ends here diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index d64d0ed0006..57801d6f9e6 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -1047,7 +1047,7 @@ will be copied over from that buffer." (list (list group "")) nnmail-split-methods))) ;; Insert the incoming file. - (with-current-buffer (get-buffer-create nnmail-article-buffer) + (with-current-buffer (gnus-get-buffer-create nnmail-article-buffer) (erase-buffer) (if (bufferp incoming) (insert-buffer-substring incoming) @@ -1574,7 +1574,7 @@ See the documentation for the variable `nnmail-split-fancy' for details." () ; The buffer is open. (with-current-buffer (setq nnmail-cache-buffer - (get-buffer-create " *nnmail message-id cache*")) + (gnus-get-buffer-create " *nnmail message-id cache*")) (gnus-add-buffer) (when (file-exists-p nnmail-message-id-cache-file) (nnheader-insert-file-contents nnmail-message-id-cache-file)) @@ -1749,7 +1749,15 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (nreverse (nnmail-article-group artnum-func)))))) ;; Add the group-art list to the history list. (if group-art - (push group-art nnmail-split-history) + ;; We need to get the unique Gnus group name for this article + ;; -- there may be identically named groups from several + ;; backends. + (push (mapcar + (lambda (ga) + (cons (gnus-group-prefixed-name (car ga) gnus-command-method) + (cdr ga))) + group-art) + nnmail-split-history) (delete-region (point-min) (point-max))))) ;;; Get new mail. @@ -1953,12 +1961,14 @@ If TIME is nil, then return the cutoff time for oldness instead." (unless (re-search-forward "^Message-ID[ \t]*:" nil t) (insert "Message-ID: " (nnmail-message-id) "\n"))))) -(defun nnmail-write-region (start end filename &optional append visit lockname) +(defun nnmail-write-region (start end filename + &optional append visit lockname mustbenew) "Do a `write-region', and then set the file modes." (let ((coding-system-for-write nnmail-file-coding-system) (file-name-coding-system nnmail-pathname-coding-system)) - (write-region start end filename append visit lockname) - (set-file-modes filename nnmail-default-file-modes))) + (write-region start end filename append visit lockname mustbenew) + (set-file-modes filename nnmail-default-file-modes + (when (eq mustbenew 'excl) 'nofollow)))) ;;; ;;; Status functions @@ -2065,13 +2075,15 @@ Doesn't change point." (when nnmail-split-tracing (push split nnmail-split-trace)) (when nnmail-debug-splitting - (with-current-buffer (get-buffer-create "*nnmail split*") + (with-current-buffer (gnus-get-buffer-create "*nnmail split*") (goto-char (point-max)) (insert (format-time-string "%FT%T") " " (format "%S" split) "\n")))) +(make-obsolete-variable 'nnmail-load-hook + "use `with-eval-after-load' instead." "28.1") (run-hooks 'nnmail-load-hook) (provide 'nnmail) diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index 9cf766ee465..68c31dc4510 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -1,4 +1,4 @@ -;;; nnmaildir.el --- maildir backend for Gnus +;;; nnmaildir.el --- maildir backend for Gnus -*- lexical-binding:t -*- ;; This file is in the public domain. @@ -261,7 +261,7 @@ This variable is set by `nnmaildir-request-article'.") (defun nnmaildir--param (pgname param) (setq param (gnus-group-find-parameter pgname param 'allow-list)) (if (vectorp param) (setq param (aref param 0))) - (eval param)) + (eval param t)) (defmacro nnmaildir--with-nntp-buffer (&rest body) (declare (debug (body))) @@ -269,15 +269,15 @@ This variable is set by `nnmaildir-request-article'.") ,@body)) (defmacro nnmaildir--with-work-buffer (&rest body) (declare (debug (body))) - `(with-current-buffer (get-buffer-create " *nnmaildir work*") + `(with-current-buffer (gnus-get-buffer-create " *nnmaildir work*") ,@body)) (defmacro nnmaildir--with-nov-buffer (&rest body) (declare (debug (body))) - `(with-current-buffer (get-buffer-create " *nnmaildir nov*") + `(with-current-buffer (gnus-get-buffer-create " *nnmaildir nov*") ,@body)) (defmacro nnmaildir--with-move-buffer (&rest body) (declare (debug (body))) - `(with-current-buffer (get-buffer-create " *nnmaildir move*") + `(with-current-buffer (gnus-get-buffer-create " *nnmaildir move*") ,@body)) (defsubst nnmaildir--subdir (dir subdir) @@ -492,7 +492,7 @@ This variable is set by `nnmaildir-request-article'.") (setq nov-mid 0)) (goto-char (point-min)) (delete-char 1) - (setq nov (nnheader-parse-naked-head) + (setq nov (nnheader-parse-head t) field (or (mail-header-lines nov) 0))) (unless (or (zerop field) (nnmaildir--param pgname 'distrust-Lines:)) (setq nov-mid field)) @@ -690,7 +690,7 @@ This variable is set by `nnmaildir-request-article'.") "You must set \"directory\" in the select method") (throw 'return nil)) (setq dir (cadr dir) - dir (eval dir) + dir (eval dir t) ;FIXME: Why `eval'? dir (expand-file-name dir) dir (file-name-as-directory dir)) (unless (file-exists-p dir) @@ -717,13 +717,13 @@ This variable is set by `nnmaildir-request-article'.") (if x (progn (setq x (cadr x) - x (eval x)) + x (eval x t)) ;FIXME: Why `eval'? (setf (nnmaildir--srv-target-prefix server) x)) (setq x (assq 'create-directory defs)) (if x (progn (setq x (cadr x) - x (eval x) + x (eval x t) ;FIXME: Why `eval'? x (file-name-as-directory x)) (setf (nnmaildir--srv-target-prefix server) x)) (setf (nnmaildir--srv-target-prefix server) ""))) @@ -1428,7 +1428,7 @@ This variable is set by `nnmaildir-request-article'.") (nnmaildir--with-move-buffer (erase-buffer) (nnheader-insert-file-contents nnmaildir--file) - (setq result (eval accept-form))) + (setq result (eval accept-form t))) (unless (or (null result) (nnmaildir--param pgname 'read-only)) (nnmaildir--unlink nnmaildir--file) (nnmaildir--expired-article group article)) @@ -1544,7 +1544,7 @@ This variable is set by `nnmaildir-request-article'.") (defun nnmaildir-request-expire-articles (ranges &optional gname server force) (let ((no-force (not force)) (group (nnmaildir--prepare server gname)) - pgname time boundary high low target dir nlist + pgname time boundary target dir nlist didnt nnmaildir--file nnmaildir-article-file-name deactivate-mark) (catch 'return @@ -1720,18 +1720,23 @@ This variable is set by `nnmaildir-request-article'.") (defun nnmaildir-close-group (gname &optional server) (let ((group (nnmaildir--prepare server gname)) - pgname ls dir msgdir files flist dirs) + pgname ls dir msgdir files dirs + (fset (make-hash-table :test #'equal))) (if (null group) (progn (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) nil) + ;; Delete the now obsolete NOV files. + ;; FIXME: This can take a somewhat long time, so maybe it's better + ;; to do it asynchronously (i.e. in an idle timer). (setq pgname (nnmaildir--pgname nnmaildir--cur-server gname) ls (nnmaildir--group-ls nnmaildir--cur-server pgname) dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir gname) msgdir (if (nnmaildir--param pgname 'read-only) (nnmaildir--new dir) (nnmaildir--cur dir)) + ;; The dir with the NOV files. dir (nnmaildir--nndir dir) dirs (cons (nnmaildir--nov-dir dir) (funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]" @@ -1744,14 +1749,15 @@ This variable is set by `nnmaildir-request-article'.") (save-match-data (dolist (file files) (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file) - (push (match-string 1 file) flist))) + (puthash (match-string 1 file) t fset))) + ;; Not sure why, but we specifically avoid deleting the `:' file. + (puthash ":" t fset) (dolist (dir dirs) (setq files (cdr dir) dir (file-name-as-directory (car dir))) (dolist (file files) - (unless (or (member file flist) (string= file ":")) - (setq file (concat dir file)) - (delete-file file)))) + (unless (gethash file fset) + (delete-file (concat dir file))))) t))) (defun nnmaildir-close-server (&optional server _defs) diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el index b3329212f84..dcecfcf6519 100644 --- a/lisp/gnus/nnmairix.el +++ b/lisp/gnus/nnmairix.el @@ -1249,7 +1249,7 @@ Marks propagation has to be enabled for this to work." If THREADS is non-nil, enable full threads." (let ((args (cons (car command) '(nil t nil)))) (with-current-buffer - (get-buffer-create nnmairix-mairix-output-buffer) + (gnus-get-buffer-create nnmairix-mairix-output-buffer) (erase-buffer) (when (> (length command) 1) (setq args (append args (cdr command)))) @@ -1267,7 +1267,7 @@ If THREADS is non-nil, enable full threads." "Call mairix binary with COMMAND and QUERY in raw mode." (let ((args (cons (car command) '(nil t nil)))) (with-current-buffer - (get-buffer-create nnmairix-mairix-output-buffer) + (gnus-get-buffer-create nnmairix-mairix-output-buffer) (erase-buffer) (when (> (length command) 1) (setq args (append args (cdr command)))) @@ -1404,7 +1404,7 @@ TYPE is either `nov' or `headers'." (nnheader-message 7 "nnmairix: Rewriting headers...") (cond ((eq type 'nov) - (let ((buf (get-buffer-create " *nnmairix buffer*")) + (let ((buf (gnus-get-buffer-create " *nnmairix buffer*")) (corr (not (zerop numc))) (name (buffer-name nntp-server-buffer)) header cur xref) diff --git a/lisp/gnus/nnmbox.el b/lisp/gnus/nnmbox.el index eb8fcf37a25..8b3d80266e7 100644 --- a/lisp/gnus/nnmbox.el +++ b/lisp/gnus/nnmbox.el @@ -280,7 +280,7 @@ (deffoo nnmbox-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nnmbox move*")) + (let ((buf (gnus-get-buffer-create " *nnmbox move*")) result) (and (nnmbox-request-article article group server) @@ -613,7 +613,7 @@ (dir (file-name-directory nnmbox-mbox-file))) (and dir (gnus-make-directory dir)) (nnmail-write-region (point-min) (point-min) - nnmbox-mbox-file t 'nomesg)))) + nnmbox-mbox-file t 'nomesg nil 'excl)))) (defun nnmbox-read-mbox () (nnmail-activate 'nnmbox) diff --git a/lisp/gnus/nnmh.el b/lisp/gnus/nnmh.el index 8e7f0565e67..581a408009d 100644 --- a/lisp/gnus/nnmh.el +++ b/lisp/gnus/nnmh.el @@ -296,7 +296,7 @@ as unread by Gnus.") (deffoo nnmh-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nnmh move*")) + (let ((buf (gnus-get-buffer-create " *nnmh move*")) result) (and (nnmh-deletable-article-p group article) diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index 6c7b25b5e76..ad608b6575e 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -361,7 +361,7 @@ non-nil.") (deffoo nnml-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nnml move*")) + (let ((buf (gnus-get-buffer-create " *nnml move*")) (file-name-coding-system nnmail-pathname-coding-system) result) (nnml-possibly-change-directory group server) @@ -572,7 +572,7 @@ non-nil.") ;; Find an article number in the current group given the Message-ID. (defun nnml-find-group-number (id server) - (with-current-buffer (get-buffer-create " *nnml id*") + (with-current-buffer (gnus-get-buffer-create " *nnml id*") (let ((alist nnml-group-alist) number) ;; We want to look through all .overview files, but we want to @@ -766,17 +766,16 @@ article number. This function is called narrowed to an article." (if (re-search-forward "\n\r?\n" nil t) (1- (point)) (point-max)))) - (let ((headers (nnheader-parse-naked-head))) + (let ((headers (nnheader-parse-head t))) (setf (mail-header-chars headers) chars) (setf (mail-header-number headers) number) headers)))) (defun nnml-get-nov-buffer (group &optional incrementalp) - (let ((buffer (get-buffer-create (format " *nnml %soverview %s*" - (if incrementalp - "incremental " - "") - group))) + (let ((buffer (gnus-get-buffer-create + (format " *nnml %soverview %s*" + (if incrementalp "incremental " "") + group))) (file-name-coding-system nnmail-pathname-coding-system)) (with-current-buffer buffer (set (make-local-variable 'nnml-nov-buffer-file-name) @@ -873,7 +872,7 @@ Unless no-active is non-nil, update the active file too." (defun nnml-generate-nov-file (dir files) (let* ((dir (file-name-as-directory dir)) (nov (concat dir nnml-nov-file-name)) - (nov-buffer (get-buffer-create " *nov*")) + (nov-buffer (gnus-get-buffer-create " *nov*")) chars file headers) (with-current-buffer nov-buffer ;; Init the nov buffer. @@ -902,7 +901,7 @@ Unless no-active is non-nil, update the active file too." (nnheader-insert-nov headers))) (widen)))) (with-current-buffer nov-buffer - (nnmail-write-region (point-min) (point-max) nov nil 'nomesg) + (nnmail-write-region (point-min) (point-max) nov nil 'nomesg nil 'excl) (kill-buffer (current-buffer)))))) (defun nnml-nov-delete-article (group article) diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index fa4d22fb1cc..48c07da1cc8 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -450,7 +450,7 @@ nnrss: %s: Not valid XML %s and libxml-parse-html-region doesn't work %s" (defun nnrss-normalize-date (date) "Return a date string of DATE in the style of RFC 822 and its successors. This function handles the ISO 8601 date format described in -URL `http://www.w3.org/TR/NOTE-datetime', and also the RFC 822 style +URL `https://www.w3.org/TR/NOTE-datetime', and also the RFC 822 style which RSS 2.0 allows." (let (case-fold-search vector year month day time zone cts given) (cond ((null date)) ; do nothing for this case @@ -739,7 +739,7 @@ Read the file and attempt to subscribe to each Feed in the file." "OPML subscription export. Export subscriptions to a buffer in OPML Format." (interactive) - (with-current-buffer (get-buffer-create "*OPML Export*") + (with-current-buffer (gnus-get-buffer-create "*OPML Export*") (set-buffer-file-coding-system 'utf-8) (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n" "<!-- OPML generated by Emacs Gnus' nnrss.el -->\n" diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el new file mode 100644 index 00000000000..e4753fe95c8 --- /dev/null +++ b/lisp/gnus/nnselect.el @@ -0,0 +1,970 @@ +;;; nnselect.el --- a virtual group backend -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Andrew Cohen <cohen@andy.bu.edu> +;; Keywords: news mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This is a "virtual" backend that allows an arbitrary list of +;; articles to be treated as a Gnus group. An nnselect group uses an +;; `nnselect-spec' group parameter to specify this list of +;; articles. `nnselect-spec' is an alist with two keys: +;; `nnselect-function', whose value should be a function that returns +;; the list of articles, and `nnselect-args'. The function will be +;; applied to the arguments to generate the list of articles. The +;; return value should be a vector, each element of which should in +;; turn be a vector of three elements: a real prefixed group name, an +;; article number in that group, and an integer score. The score is +;; not used by nnselect but may be used by other code to help in +;; sorting. Most functions will just chose a fixed number, such as +;; 100, for this score. + +;; For example the search function `gnus-search-run-query' applied to +;; arguments specifying a search query (see "gnus-search.el") can be +;; used to return a list of articles from a search. Or the function +;; can be the identity and the args a vector of articles. + + +;;; Code: + +;;; Setup: + +(require 'gnus-art) +(require 'gnus-search) + +(eval-when-compile (require 'cl-lib)) + +;; Set up the backend + +(nnoo-declare nnselect) + +(nnoo-define-basics nnselect) + +(gnus-declare-backend "nnselect" 'post-mail 'virtual) + +;;; Internal Variables: + +(defvar gnus-inhibit-demon) +(defvar gnus-message-group-art) + +;; For future use +(defvoo nnselect-directory gnus-directory + "Directory for the nnselect backend.") + +(defvoo nnselect-active-file + (expand-file-name "nnselect-active" nnselect-directory) + "nnselect active file.") + +(defvoo nnselect-groups-file + (expand-file-name "nnselect-newsgroups" nnselect-directory) + "nnselect groups description file.") + +;;; Helper routines. +(defun nnselect-compress-artlist (artlist) + "Compress ARTLIST." + (let (selection) + (pcase-dolist (`(,artgroup . ,arts) + (nnselect-categorize artlist 'nnselect-artitem-group)) + (let (list) + (pcase-dolist (`(,rsv . ,articles) + (nnselect-categorize + arts 'nnselect-artitem-rsv 'nnselect-artitem-number)) + (push (cons rsv (gnus-compress-sequence (sort articles '<))) + list)) + (push (cons artgroup list) selection))) + selection)) + +(defun nnselect-uncompress-artlist (artlist) + "Uncompress ARTLIST." + (if (vectorp artlist) + artlist + (let (selection) + (pcase-dolist (`(,artgroup (,artrsv . ,artseq)) artlist) + (setq selection + (vconcat + (cl-map 'vector + #'(lambda (art) + (vector artgroup art artrsv)) + (gnus-uncompress-sequence artseq)) selection))) + selection))) + +(make-obsolete 'nnselect-group-server 'gnus-group-server "28.1") + +;; Data type article list. + +(define-inline nnselect-artlist-length (artlist) + (inline-quote (length ,artlist))) + +(define-inline nnselect-artlist-article (artlist n) + "Return from ARTLIST the Nth artitem (counting starting at 1)." + (inline-quote (when (> ,n 0) + (elt ,artlist (1- ,n))))) + +(define-inline nnselect-artitem-group (artitem) + "Return the group from the ARTITEM." + (inline-quote (elt ,artitem 0))) + +(define-inline nnselect-artitem-number (artitem) + "Return the number from the ARTITEM." + (inline-quote (elt ,artitem 1))) + +(define-inline nnselect-artitem-rsv (artitem) + "Return the Retrieval Status Value (RSV, score) from the ARTITEM." + (inline-quote (elt ,artitem 2))) + +(define-inline nnselect-article-group (article) + "Return the group for ARTICLE." + (inline-quote + (nnselect-artitem-group (nnselect-artlist-article + gnus-newsgroup-selection ,article)))) + +(define-inline nnselect-article-number (article) + "Return the number for ARTICLE." + (inline-quote (nnselect-artitem-number + (nnselect-artlist-article + gnus-newsgroup-selection ,article)))) + +(define-inline nnselect-article-rsv (article) + "Return the rsv for ARTICLE." + (inline-quote (nnselect-artitem-rsv + (nnselect-artlist-article + gnus-newsgroup-selection ,article)))) + +(define-inline nnselect-article-id (article) + "Return the pair `(nnselect id . real id)' of ARTICLE." + (inline-quote (cons ,article (nnselect-article-number ,article)))) + +(define-inline nnselect-categorize (sequence keyfunc &optional valuefunc) + "Sorts a sequence into categories. +Returns a list of the form +`((key1 (element11 element12)) (key2 (element21 element22))'. +The category key for a member of the sequence is obtained +as `(keyfunc member)' and the corresponding element is just +`member' (or `(valuefunc member)' if `valuefunc' is non-nil)." + (inline-letevals (sequence keyfunc valuefunc) + (inline-quote (let ((valuefunc (or ,valuefunc 'identity)) + result) + (unless (null ,sequence) + (mapc + (lambda (member) + (let* ((key (funcall ,keyfunc member)) + (value (funcall valuefunc member)) + (kr (assoc key result))) + (if kr + (push value (cdr kr)) + (push (list key value) result)))) + (reverse ,sequence)) + result))))) + + +;; Unclear whether a macro or an inline function is best. +;; (defmacro nnselect-categorize (sequence keyfunc &optional valuefunc) +;; "Sorts a sequence into categories and returns a list of the form +;; `((key1 (element11 element12)) (key2 (element21 element22))'. +;; The category key for a member of the sequence is obtained +;; as `(keyfunc member)' and the corresponding element is just +;; `member' (or `(valuefunc member)' if `valuefunc' is non-nil)." +;; (let ((key (make-symbol "key")) +;; (value (make-symbol "value")) +;; (result (make-symbol "result")) +;; (valuefunc (or valuefunc 'identity))) +;; `(unless (null ,sequence) +;; (let (,result) +;; (mapc +;; (lambda (member) +;; (let* ((,key (,keyfunc member)) +;; (,value (,valuefunc member)) +;; (kr (assoc ,key ,result))) +;; (if kr +;; (push ,value (cdr kr)) +;; (push (list ,key ,value) ,result)))) +;; (reverse ,sequence)) +;; ,result)))) + +(define-inline ids-by-group (articles) + (inline-quote + (nnselect-categorize ,articles 'nnselect-article-group + 'nnselect-article-id))) + +(define-inline numbers-by-group (articles &optional type) + (inline-quote + (cond + ((eq ,type 'range) + (nnselect-categorize (gnus-uncompress-range ,articles) + 'nnselect-article-group 'nnselect-article-number)) + ((eq ,type 'tuple) + (nnselect-categorize ,articles + #'(lambda (elem) + (nnselect-article-group (car elem))) + #'(lambda (elem) + (cons (nnselect-article-number + (car elem)) (cdr elem))))) + (t + (nnselect-categorize ,articles + 'nnselect-article-group 'nnselect-article-number))))) + +(defmacro nnselect-add-prefix (group) + "Ensures that the GROUP has an nnselect prefix." + `(gnus-group-prefixed-name + (gnus-group-short-name ,group) '(nnselect "nnselect"))) + +(defmacro nnselect-get-artlist (group) + "Retrieve the list of articles for GROUP." + `(when (gnus-nnselect-group-p ,group) + (nnselect-uncompress-artlist + (gnus-group-get-parameter ,group 'nnselect-artlist t)))) + +(defmacro nnselect-add-novitem (novitem) + "Add NOVITEM to the list of headers." + `(let* ((novitem ,novitem) + (artno (and novitem + (mail-header-number novitem))) + (art (car-safe (rassq artno artids)))) + (when art + (setf (mail-header-number novitem) art) + (push novitem headers)))) + +;;; User Customizable Variables: + +(defgroup nnselect nil + "Virtual groups in Gnus with arbitrary selection methods." + :group 'gnus) + +(define-obsolete-variable-alias 'nnir-retrieve-headers-override-function + 'nnselect-retrieve-headers-override-function "28.1") + +(defcustom nnselect-retrieve-headers-override-function nil + "A function that retrieves article headers for ARTICLES from GROUP. +The retrieved headers should populate the `nntp-server-buffer'. +Returns either the retrieved header format 'nov or 'headers. + +If this variable is nil, or if the provided function returns nil, + `gnus-retrieve-headers' will be called instead." + :version "28.1" + :type '(repeat function)) + +;; Gnus backend interface functions. + +(deffoo nnselect-open-server (server &optional definitions) + ;; Just set the server variables appropriately. + (let ((backend (or (car (gnus-server-to-method server)) 'nnselect))) + (nnoo-change-server backend server definitions))) + +;; (deffoo nnselect-server-opened (&optional server) +;; "Is SERVER the current virtual server?" +;; (if (string-empty-p server) +;; t +;; (let ((backend (car (gnus-server-to-method server)))) +;; (nnoo-current-server-p (or backend 'nnselect) server)))) + +(deffoo nnselect-server-opened (&optional _server) + t) + + +(deffoo nnselect-request-group (group &optional _server _dont-check info) + (let* ((group (nnselect-add-prefix group)) + (nnselect-artlist (nnselect-get-artlist group)) + length) + ;; Check for cached select result or run the selection and cache + ;; the result. + (unless nnselect-artlist + (gnus-group-set-parameter + group 'nnselect-artlist + (nnselect-compress-artlist (setq nnselect-artlist + (nnselect-run + (gnus-group-get-parameter group 'nnselect-specs t))))) + (nnselect-request-update-info + group (or info (gnus-get-info group)))) + (if (zerop (setq length (nnselect-artlist-length nnselect-artlist))) + (progn + (nnheader-report 'nnselect "Selection produced empty results.") + (when (gnus-ephemeral-group-p group) + (gnus-kill-ephemeral-group group) + (setq gnus-ephemeral-servers + (assq-delete-all 'nnselect gnus-ephemeral-servers))) + (nnheader-insert "")) + (with-current-buffer nntp-server-buffer + (nnheader-insert "211 %d %d %d %s\n" + length ; total # + 1 ; first # + length ; last # + group))) ; group name + nnselect-artlist)) + + +(deffoo nnselect-retrieve-headers (articles group &optional _server fetch-old) + (let ((group (nnselect-add-prefix group))) + (with-current-buffer (gnus-summary-buffer-name group) + (setq gnus-newsgroup-selection (or gnus-newsgroup-selection + (nnselect-get-artlist group))) + (let ((gnus-inhibit-demon t) + (gartids (ids-by-group articles)) + headers) + (with-current-buffer nntp-server-buffer + (pcase-dolist (`(,artgroup . ,artids) gartids) + (let ((artlist (sort (mapcar 'cdr artids) '<)) + (gnus-override-method (gnus-find-method-for-group artgroup)) + (fetch-old + (or + (car-safe + (gnus-group-find-parameter artgroup + 'gnus-fetch-old-headers t)) + fetch-old))) + (erase-buffer) + (pcase (setq gnus-headers-retrieved-by + (or + (and + nnselect-retrieve-headers-override-function + (funcall + nnselect-retrieve-headers-override-function + artlist artgroup)) + (gnus-retrieve-headers + artlist artgroup fetch-old))) + ('nov + (goto-char (point-min)) + (while (not (eobp)) + (nnselect-add-novitem + (nnheader-parse-nov)) + (forward-line 1))) + ('headers + (gnus-run-hooks 'gnus-parse-headers-hook) + (let ((nnmail-extra-headers gnus-extra-headers)) + (goto-char (point-min)) + (while (not (eobp)) + (nnselect-add-novitem + (nnheader-parse-head)) + (forward-line 1)))) + ((pred listp) + (dolist (novitem gnus-headers-retrieved-by) + (nnselect-add-novitem novitem))) + (_ (error "Unknown header type %s while requesting articles \ + of group %s" gnus-headers-retrieved-by artgroup))))) + (setq headers + (sort + headers + (lambda (x y) + (< (mail-header-number x) (mail-header-number y)))))))))) + + +(deffoo nnselect-request-article (article &optional _group server to-buffer) + (let* ((gnus-override-method nil) + servers group-art artlist) + (if (numberp article) + (with-current-buffer gnus-summary-buffer + (unless (zerop (nnselect-artlist-length + gnus-newsgroup-selection)) + (setq group-art (cons (nnselect-article-group article) + (nnselect-article-number article))))) + ;; message-id: either coming from a referral or a pseudo-article + ;; find the servers for a pseudo-article + (if (eq 'nnselect (car (gnus-server-to-method server))) + (with-current-buffer gnus-summary-buffer + (let ((thread (gnus-id-to-thread article))) + (when thread + (mapc + (lambda (x) + (when (and x (> x 0)) + (cl-pushnew + (list + (gnus-method-to-server + (gnus-find-method-for-group + (nnselect-article-group x)))) servers :test 'equal))) + (gnus-articles-in-thread thread))))) + (setq servers (list (list server)))) + (setq artlist + (gnus-search-run-query + (list + (cons 'search-query-spec + (list (cons 'query `((id . ,article))) + (cons 'criteria "") (cons 'shortcut t))) + (cons 'search-group-spec servers)))) + (unless (zerop (nnselect-artlist-length artlist)) + (setq + group-art + (cons + (nnselect-artitem-group (nnselect-artlist-article artlist 1)) + (nnselect-artitem-number (nnselect-artlist-article artlist 1)))))) + (when (numberp (cdr group-art)) + (message "Requesting article %d from group %s" + (cdr group-art) (car group-art)) + (if to-buffer + (with-current-buffer to-buffer + (let ((gnus-article-decode-hook nil)) + (gnus-request-article-this-buffer + (cdr group-art) (car group-art)))) + (gnus-request-article (cdr group-art) (car group-art))) + group-art))) + + +(deffoo nnselect-request-move-article + (article _group _server accept-form &optional last _internal-move-group) + (let* ((artgroup (nnselect-article-group article)) + (artnumber (nnselect-article-number article)) + (to-newsgroup (nth 1 accept-form)) + (to-method (gnus-find-method-for-group to-newsgroup)) + (from-method (gnus-find-method-for-group artgroup)) + (move-is-internal (gnus-server-equal from-method to-method))) + (unless (gnus-check-backend-function + 'request-move-article artgroup) + (error "The group %s does not support article moving" artgroup)) + (gnus-request-move-article + artnumber + artgroup + (nth 1 from-method) + accept-form + last + (and move-is-internal + to-newsgroup ; Not respooling + (gnus-group-real-name to-newsgroup))))) + +(deffoo nnselect-request-replace-article + (article _group buffer &optional no-encode) + (pcase-let ((`[,artgroup ,artnumber ,artrsv] + (with-current-buffer gnus-summary-buffer + (nnselect-artlist-article gnus-newsgroup-selection article)))) + (unless (gnus-check-backend-function + 'request-replace-article artgroup) + (user-error "The group %s does not support article editing" artgroup)) + (let ((newart + (gnus-request-replace-article artnumber artgroup buffer no-encode))) + (with-current-buffer gnus-summary-buffer + (cl-nsubstitute `[,artgroup ,newart ,artrsv] + `[,artgroup ,artnumber ,artrsv] + gnus-newsgroup-selection + :test #'equal :count 1))))) + +(deffoo nnselect-request-expire-articles + (articles _group &optional _server force) + (if force + (let (not-expired) + (pcase-dolist (`(,artgroup . ,artids) (ids-by-group articles)) + (let ((artlist (sort (mapcar 'cdr artids) '<))) + (unless (gnus-check-backend-function 'request-expire-articles + artgroup) + (error "Group %s does not support article expiration" artgroup)) + (unless (gnus-check-server (gnus-find-method-for-group artgroup)) + (error "Couldn't open server for group %s" artgroup)) + (push (mapcar #'(lambda (art) + (car (rassq art artids))) + (let ((nnimap-expunge 'immediately)) + (gnus-request-expire-articles + artlist artgroup force))) + not-expired))) + (sort (delq nil not-expired) '<)) + articles)) + + +(deffoo nnselect-warp-to-article () + (let* ((cur (if (> (gnus-summary-article-number) 0) + (gnus-summary-article-number) + (error "Can't warp to a pseudo-article"))) + (artgroup (nnselect-article-group cur)) + (artnumber (nnselect-article-number cur)) + (_quit-config (gnus-ephemeral-group-p gnus-newsgroup-name))) + + ;; what should we do here? we could leave all the buffers around + ;; and assume that we have to exit from them one by one. or we can + ;; try to clean up directly + + ;;first exit from the nnselect summary buffer. + ;;(gnus-summary-exit) + ;; and if the nnselect summary buffer in turn came from another + ;; summary buffer we have to clean that summary up too. + ;;(when (not (eq (cdr quit-config) 'group)) + ;; (gnus-summary-exit)) + (gnus-summary-read-group-1 artgroup t t nil + nil (list artnumber)))) + + +;; we pass this through to the real group in case it wants to adjust +;; the mark. We also use this to mark an article expirable iff it is +;; expirable in the real group. +(deffoo nnselect-request-update-mark (_group article mark) + (let* ((artgroup (nnselect-article-group article)) + (artnumber (nnselect-article-number article)) + (gmark (gnus-request-update-mark artgroup artnumber mark))) + (when (and artnumber + (memq mark gnus-auto-expirable-marks) + (= mark gmark) + (gnus-group-auto-expirable-p artgroup)) + (setq gmark gnus-expirable-mark)) + gmark)) + + +(deffoo nnselect-request-set-mark (_group actions &optional _server) + (mapc + (lambda (request) (gnus-request-set-mark (car request) (cdr request))) + (nnselect-categorize + (cl-mapcan + (lambda (act) + (cl-destructuring-bind (range action marks) act + (mapcar + (lambda (artgroup) + (list (car artgroup) + (gnus-compress-sequence (sort (cdr artgroup) '<)) + action marks)) + (numbers-by-group range 'range)))) + actions) + 'car 'cdr))) + +(deffoo nnselect-request-update-info (group info &optional _server) + (let* ((group (nnselect-add-prefix group)) + (gnus-newsgroup-selection + (or gnus-newsgroup-selection (nnselect-get-artlist group))) + newmarks) + (gnus-info-set-marks info nil) + (setf (gnus-info-read info) nil) + (pcase-dolist (`(,artgroup . ,nartids) + (ids-by-group + (number-sequence 1 (nnselect-artlist-length + gnus-newsgroup-selection)))) + (let* ((gnus-newsgroup-active nil) + (artids (cl-sort nartids #'< :key 'car)) + (group-info (gnus-get-info artgroup)) + (marks (gnus-info-marks group-info)) + (unread (gnus-uncompress-sequence + (gnus-range-difference (gnus-active artgroup) + (gnus-info-read group-info))))) + (setf (gnus-info-read info) + (gnus-add-to-range + (gnus-info-read info) + (delq nil (mapcar + #'(lambda (art) + (unless (memq (cdr art) unread) (car art))) + artids)))) + (pcase-dolist (`(,type . ,mark-list) marks) + (let ((mark-type (gnus-article-mark-to-type type)) new) + (when + (setq new + (delq nil + (cond + ((eq mark-type 'tuple) + (mapcar + #'(lambda (id) + (let (mark) + (when + (setq mark (assq (cdr id) mark-list)) + (cons (car id) (cdr mark))))) + artids)) + (t + (setq mark-list + (gnus-uncompress-range mark-list)) + (mapcar + #'(lambda (id) + (when (memq (cdr id) mark-list) + (car id))) artids))))) + (let ((previous (alist-get type newmarks))) + (if previous + (nconc previous new) + (push (cons type new) newmarks)))))))) + + ;; Clean up the marks: compress lists; + (pcase-dolist (`(,type . ,mark-list) newmarks) + (let ((mark-type (gnus-article-mark-to-type type))) + (unless (eq mark-type 'tuple) + (setf (alist-get type newmarks) + (gnus-compress-sequence mark-list))))) + ;; and ensure an unexist key. + (unless (assq 'unexist newmarks) + (push (cons 'unexist nil) newmarks)) + + (gnus-info-set-marks info newmarks) + (gnus-set-active group (cons 1 (nnselect-artlist-length + gnus-newsgroup-selection))))) + + +(deffoo nnselect-request-thread (header &optional group server) + (with-current-buffer gnus-summary-buffer + (let ((group (nnselect-add-prefix group)) + ;; find the best group for the originating article. if its a + ;; pseudo-article look for real articles in the same thread + ;; and see where they come from. + (artgroup (nnselect-article-group + (if (> (mail-header-number header) 0) + (mail-header-number header) + (if (> (gnus-summary-article-number) 0) + (gnus-summary-article-number) + (let ((thread + (gnus-id-to-thread (mail-header-id header)))) + (when thread + (cl-some #'(lambda (x) + (when (and x (> x 0)) x)) + (gnus-articles-in-thread thread))))))))) + ;; Check if search-based thread referral is permitted, and + ;; available. + (if (and gnus-refer-thread-use-search + (gnus-search-server-to-engine + (gnus-method-to-server + (gnus-find-method-for-group artgroup)))) + ;; If so we perform the query, massage the result, and return + ;; the new headers back to the caller to incorporate into the + ;; current summary buffer. + (let* ((group-spec + (list (delq nil (list + (or server (gnus-group-server artgroup)) + (unless gnus-refer-thread-use-search + artgroup))))) + (ids (cons (mail-header-id header) + (split-string + (or (mail-header-references header) + "")))) + (query-spec + (list (cons 'query (mapconcat (lambda (i) + (format "id:%s" i)) + ids " or ")) + (cons 'thread t))) + (last (nnselect-artlist-length gnus-newsgroup-selection)) + (first (1+ last)) + (new-nnselect-artlist + (gnus-search-run-query + (list (cons 'search-query-spec query-spec) + (cons 'search-group-spec group-spec)))) + old-arts seq + headers) + (mapc + #'(lambda (article) + (if + (setq seq + (cl-position article + gnus-newsgroup-selection :test 'equal)) + (push (1+ seq) old-arts) + (setq gnus-newsgroup-selection + (vconcat gnus-newsgroup-selection (vector article))) + (cl-incf last))) + new-nnselect-artlist) + (setq headers + (gnus-fetch-headers + (append (sort old-arts '<) + (number-sequence first last)) nil t)) + (gnus-group-set-parameter + group + 'nnselect-artlist + (nnselect-compress-artlist gnus-newsgroup-selection)) + (when (>= last first) + (let (new-marks) + (pcase-dolist (`(,artgroup . ,artids) + (ids-by-group (number-sequence first last))) + (pcase-dolist (`(,type . ,marked) + (gnus-info-marks (gnus-get-info artgroup))) + (setq marked (gnus-uncompress-sequence marked)) + (when (setq new-marks + (delq nil + (mapcar + #'(lambda (art) + (when (memq (cdr art) marked) + (car art))) + artids))) + (nconc + (symbol-value + (intern + (format "gnus-newsgroup-%s" + (car (rassq type gnus-article-mark-lists))))) + new-marks))))) + (setq gnus-newsgroup-active + (cons 1 (nnselect-artlist-length gnus-newsgroup-selection))) + (gnus-set-active + group + (cons 1 (nnselect-artlist-length gnus-newsgroup-selection)))) + headers) + ;; If we can't or won't use search, just warp to the original + ;; group and punt back to gnus-summary-refer-thread. + (and (gnus-warp-to-article) (gnus-summary-refer-thread)))))) + + +(deffoo nnselect-close-group (group &optional _server) + (let ((group (nnselect-add-prefix group))) + (unless gnus-group-is-exiting-without-update-p + (nnselect-push-info group)) + (setq gnus-newsgroup-selection nil) + (when (gnus-ephemeral-group-p group) + (gnus-kill-ephemeral-group group) + (setq gnus-ephemeral-servers + (assq-delete-all 'nnselect gnus-ephemeral-servers))))) + + +(deffoo nnselect-request-create-group (group &optional _server args) + (message "Creating nnselect group %s" group) + (let* ((group (gnus-group-prefixed-name group '(nnselect "nnselect"))) + (specs (assq 'nnselect-specs args)) + (function-spec + (or (alist-get 'nnselect-function specs) + (intern (completing-read "Function: " obarray #'functionp)))) + (args-spec + (or (alist-get 'nnselect-args specs) + (read-from-minibuffer "Args: " nil nil t nil "nil"))) + (nnselect-specs (list (cons 'nnselect-function function-spec) + (cons 'nnselect-args args-spec)))) + (gnus-group-set-parameter group 'nnselect-specs nnselect-specs) + (gnus-group-set-parameter + group 'nnselect-artlist + (nnselect-compress-artlist (or (alist-get 'nnselect-artlist args) + (nnselect-run nnselect-specs)))) + (nnselect-request-update-info group (gnus-get-info group))) + t) + + +(deffoo nnselect-request-type (_group &optional article) + (if (and (numberp article) (> article 0)) + (gnus-request-type + (nnselect-article-group article) (nnselect-article-number article)) + 'unknown)) + +(deffoo nnselect-request-post (&optional _server) + (if (not gnus-message-group-art) + (nnheader-report 'nnselect "Can't post to an nnselect group") + (gnus-request-post + (gnus-find-method-for-group + (nnselect-article-group (cdr gnus-message-group-art)))))) + + +(deffoo nnselect-request-rename-group (_group _new-name &optional _server) + t) + + +(deffoo nnselect-request-scan (group _method) + (when (and group + (gnus-group-get-parameter (nnselect-add-prefix group) + 'nnselect-rescan t)) + (nnselect-request-group-scan group))) + + +(deffoo nnselect-request-group-scan (group &optional _server _info) + (let* ((group (nnselect-add-prefix group)) + (artlist (nnselect-run + (gnus-group-get-parameter group 'nnselect-specs t)))) + (gnus-set-active group (cons 1 (nnselect-artlist-length + artlist))) + (gnus-group-set-parameter + group 'nnselect-artlist + (nnselect-compress-artlist artlist)))) + +;; Add any undefined required backend functions + +;; (nnoo-define-skeleton nnselect) + +;;; Util Code: + +(defun gnus-nnselect-group-p (group) + "Say whether GROUP is nnselect or not." + (or (and (gnus-group-prefixed-p group) + (eq 'nnselect (car (gnus-find-method-for-group group)))) + (eq 'nnselect (car gnus-command-method)))) + + +(defun nnselect-run (specs) + "Apply nnselect-function to nnselect-args from SPECS. +Return an article list." + (let ((func (alist-get 'nnselect-function specs)) + (args (alist-get 'nnselect-args specs))) + (condition-case err + (funcall func args) + (error (gnus-error 3 "nnselect-run: %s on %s gave error %s" func args err) + [])))) + +(defun nnselect-search-thread (header) + "Make an nnselect group containing the thread with article HEADER. +The current server will be searched. If the registry is +installed, the server that the registry reports the current +article came from is also searched." + (let* ((ids (cons (mail-header-id header) + (split-string + (or (mail-header-references header) + "")))) + (query + (list (cons 'query (mapconcat (lambda (i) + (format "id:%s" i)) + ids " or ")) + (cons 'thread t))) + (server + (list (list (gnus-method-to-server + (gnus-find-method-for-group gnus-newsgroup-name))))) + (registry-group (and + (bound-and-true-p gnus-registry-enabled) + (car (gnus-registry-get-id-key + (mail-header-id header) 'group)))) + (registry-server + (and registry-group + (gnus-method-to-server + (gnus-find-method-for-group registry-group))))) + (when registry-server (cl-pushnew (list registry-server) server + :test 'equal)) + (gnus-group-read-ephemeral-group + (concat "nnselect-" (message-unique-id)) + (list 'nnselect "nnselect") + nil + (cons (current-buffer) gnus-current-window-configuration) + ; nil + nil nil + (list + (cons 'nnselect-specs + (list + (cons 'nnselect-function 'gnus-search-run-query) + (cons 'nnselect-args + (list (cons 'search-query-spec query) + (cons 'search-group-spec server))))) + (cons 'nnselect-artlist nil))) + (gnus-summary-goto-subject (gnus-id-to-article (mail-header-id header))))) + + + +(defun nnselect-push-info (group) + "Copy mark-lists from GROUP to the originating groups." + (let ((select-unreads (numbers-by-group gnus-newsgroup-unreads)) + (select-reads (numbers-by-group + (gnus-info-read (gnus-get-info group)) 'range)) + (select-unseen (numbers-by-group gnus-newsgroup-unseen)) + (gnus-newsgroup-active nil) mark-list) + ;; collect the set of marked article lists categorized by + ;; originating groups + (pcase-dolist (`(,mark . ,type) gnus-article-mark-lists) + (let (type-list) + (when (setq type-list + (symbol-value (intern (format "gnus-newsgroup-%s" mark)))) + (push (cons + type + (numbers-by-group type-list (gnus-article-mark-to-type type))) + mark-list)))) + ;; now work on each originating group one at a time + (pcase-dolist (`(,artgroup . ,artlist) + (numbers-by-group gnus-newsgroup-articles)) + (let* ((group-info (gnus-get-info artgroup)) + (old-unread (gnus-list-of-unread-articles artgroup)) + newmarked delta-marks) + (when group-info + ;; iterate over mark lists for this group + (pcase-dolist (`(,_mark . ,type) gnus-article-mark-lists) + (let ((list (cdr (assoc artgroup (alist-get type mark-list)))) + (mark-type (gnus-article-mark-to-type type))) + + ;; When the backend can store marks we collect any + ;; changes. Unlike a normal group the mark lists only + ;; include marks for articles we retrieved. + (when (and (gnus-check-backend-function + 'request-set-mark artgroup) + (not (gnus-article-unpropagatable-p type))) + (let* ((old (gnus-list-range-intersection + artlist + (alist-get type (gnus-info-marks group-info)))) + (del (gnus-remove-from-range (copy-tree old) list)) + (add (gnus-remove-from-range (copy-tree list) old))) + (when add (push (list add 'add (list type)) delta-marks)) + (when del + ;; Don't delete marks from outside the active range. + ;; This shouldn't happen, but is a sanity check. + (setq del (gnus-sorted-range-intersection + (gnus-active artgroup) del)) + (push (list del 'del (list type)) delta-marks)))) + + ;; Marked sets are of mark-type 'tuple, 'list, or + ;; 'range. We merge the lists with what is already in + ;; the original info to get full list of new marks. We + ;; do this by removing all the articles we retrieved + ;; from the full list, and then add back in the newly + ;; marked ones. + (cond + ((eq mark-type 'tuple) + ;; Get rid of the entries that have the default + ;; score. + (when (and list (eq type 'score) gnus-save-score) + (let* ((arts list) + (prev (cons nil list)) + (all prev)) + (while arts + (if (or (not (consp (car arts))) + (= (cdar arts) gnus-summary-default-score)) + (setcdr prev (cdr arts)) + (setq prev arts)) + (setq arts (cdr arts))) + (setq list (cdr all)))) + ;; now merge with the original list and sort just to + ;; make sure + (setq list + (sort (map-merge + 'list list + (alist-get type (gnus-info-marks group-info))) + (lambda (elt1 elt2) + (< (car elt1) (car elt2)))))) + (t + (setq list + (gnus-compress-sequence + (gnus-sorted-union + (gnus-sorted-difference + (gnus-uncompress-sequence + (alist-get type (gnus-info-marks group-info))) + artlist) + (sort list #'<)) t))) + + ;; When exiting the group, everything that's previously been + ;; unseen is now seen. + (when (eq type 'seen) + (setq list (gnus-range-add + list (cdr (assoc artgroup select-unseen)))))) + + (when (or list (eq type 'unexist)) + (push (cons type list) newmarked)))) ;; end of mark-type loop + + (when delta-marks + (unless (gnus-check-group artgroup) + (error "Can't open server for %s" artgroup)) + (gnus-request-set-mark artgroup delta-marks)) + + (gnus-atomic-progn + (gnus-info-set-marks group-info newmarked) + ;; Cut off the end of the info if there's nothing else there. + (let ((i 5)) + (while (and (> i 2) + (not (nth i group-info))) + (when (nthcdr (cl-decf i) group-info) + (setcdr (nthcdr i group-info) nil)))) + + ;; update read and unread + (gnus-update-read-articles + artgroup + (gnus-uncompress-range + (gnus-add-to-range + (gnus-remove-from-range + old-unread + (cdr (assoc artgroup select-reads))) + (sort (cdr (assoc artgroup select-unreads)) '<)))) + (gnus-get-unread-articles-in-group + group-info (gnus-active artgroup) t) + (gnus-group-update-group artgroup t t))))))) + + +(declare-function gnus-registry-get-id-key "gnus-registry" (id key)) + +(defun gnus-summary-make-search-group (no-parse) + "Search a group from the summary buffer. +Pass NO-PARSE on to the search engine." + (interactive "P") + (gnus-warp-to-article) + (let ((spec + (list + (cons 'search-group-spec + (list (list + (gnus-group-server gnus-newsgroup-name) + gnus-newsgroup-name)))))) + (gnus-group-make-search-group no-parse spec))) + + +;; The end. +(provide 'nnselect) + +;;; nnselect.el ends here diff --git a/lisp/gnus/nnspool.el b/lisp/gnus/nnspool.el index 33b68fa989e..0b6bba5fea7 100644 --- a/lisp/gnus/nnspool.el +++ b/lisp/gnus/nnspool.el @@ -422,7 +422,7 @@ there.") (nnspool-article-pathname nnspool-current-group article)) (nnheader-insert-article-line article) (goto-char (point-min)) - (let ((headers (nnheader-parse-head))) + (let ((headers (nnheader-parse-head nil t))) (set-buffer cur) (goto-char (point-max)) (nnheader-insert-nov headers))) diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 6ce8724cbbb..a5c82447926 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -309,7 +309,7 @@ backend doesn't catch this error.") (defun nntp-record-command (string) "Record the command STRING." - (with-current-buffer (get-buffer-create "*nntp-log*") + (with-current-buffer (gnus-get-buffer-create "*nntp-log*") (goto-char (point-max)) (insert (format-time-string "%Y%m%dT%H%M%S.%3N") " " nntp-address " " string "\n"))) @@ -1247,8 +1247,8 @@ If SEND-IF-FORCE, only send authinfo to the server if the (and nntp-connection-timeout (run-at-time nntp-connection-timeout nil - `(lambda () - (nntp-kill-buffer ,pbuffer))))) + (lambda () + (nntp-kill-buffer pbuffer))))) (process (condition-case err (let ((coding-system-for-read 'binary) @@ -1263,7 +1263,17 @@ If SEND-IF-FORCE, only send authinfo to the server if the "nntpd" pbuffer nntp-address nntp-port-number :type (cadr (assoc nntp-open-connection-function map)) :end-of-command "^\\([2345]\\|[.]\\).*\n" - :capability-command "HELP\r\n" + :capability-command + (lambda (greeting) + (if (and greeting + (string-match "Typhoon" greeting)) + ;; Certain versions of the Typhoon server + ;; doesn't understand the CAPABILITIES + ;; command, but includes the capability + ;; data in the HELP command instead. + "HELP\r\n" + ;; Use the correct command for everything else. + "CAPABILITIES\r\n")) :success "^3" :starttls-function (lambda (capabilities) diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index e1290a9c774..54c2f7be820 100644 --- a/lisp/gnus/nnvirtual.el +++ b/lisp/gnus/nnvirtual.el @@ -97,7 +97,7 @@ component group will show up when you enter the virtual group.") (if (stringp (car articles)) 'headers (let ((vbuf (nnheader-set-temp-buffer - (get-buffer-create " *virtual headers*"))) + (gnus-get-buffer-create " *virtual headers*"))) (carticles (nnvirtual-partition-sequence articles)) (sysname (system-name)) cgroup carticle article result prefix) diff --git a/lisp/gnus/smiley.el b/lisp/gnus/smiley.el index d41f32801ee..3edae04fcc0 100644 --- a/lisp/gnus/smiley.el +++ b/lisp/gnus/smiley.el @@ -44,6 +44,7 @@ ;; cry ;-( ;; dead X-) ;; grin :-D +;; halo O:-) ;;; Code: @@ -56,18 +57,16 @@ (defvar smiley-data-directory) -(defcustom smiley-style - (if (and (fboundp 'face-attribute) - ;; In batch mode, attributes can be unspecified. - (condition-case nil - (>= (face-attribute 'default :height) 160) - (error nil))) - 'medium - 'low-color) +;; In batch mode, attributes can be unspecified. +(defcustom smiley-style (if (ignore-errors + (>= (face-attribute 'default :height) 160)) + 'medium + 'low-color) "Smiley style." :type '(choice (const :tag "small, 3 colors" low-color) ;; 13x14 (const :tag "medium, ~10 colors" medium) ;; 16x16 - (const :tag "dull, grayscale" grayscale)) ;; 14x14 + (const :tag "dull, grayscale" grayscale) ;; 14x14 + (const :tag "emoji, full color" emoji)) :set (lambda (symbol value) (set-default symbol value) (setq smiley-data-directory (smiley-directory)) @@ -99,6 +98,35 @@ is nil, use `smiley-style'." :type 'directory :group 'smiley) +(defcustom smiley-emoji-regexp-alist + '(("\\(;-)\\)\\W" 1 "π") + ("[^;]\\(;)\\)\\W" 1 "π") + ("\\(:-]\\)\\W" 1 "π¬") + ("\\(8-)\\)\\W" 1 "π₯΄") + ("\\(:-|\\)\\W" 1 "π") + ("\\(:-[/\\]\\)\\W" 1 "π") + ("\\(:-(\\)\\W" 1 "π ") + ("\\(X-)\\)\\W" 1 "π΅") ; π + ("\\(:-{\\)\\W" 1 "π¦") + ("\\(>:-)\\)\\W" 1 "π") + ("\\(;-(\\)\\W" 1 "π’") + ("\\(:-D\\)\\W" 1 "π") + ("\\(O:-)\\)\\W" 1 "π") + ;; "smile" must be come after "evil" + ("\\(\\^?:-?)\\)\\W" 1 "π")) + "A list of regexps to map smilies to emoji. +The elements are (REGEXP MATCH EMOJI), where MATCH is the submatch in +regexp to replace with EMOJI." + :version "28.1" + :type '(repeat (list regexp + (integer :tag "Regexp match number") + (string :tag "Emoji"))) + :set (lambda (symbol value) + (set-default symbol value) + (smiley-update-cache)) + :initialize 'custom-initialize-default + :group 'smiley) + ;; The XEmacs version has a baroque, if not rococo, set of these. (defcustom smiley-regexp-alist '(("\\(;-)\\)\\W" 1 "blink") @@ -145,23 +173,25 @@ regexp to replace with IMAGE. IMAGE is the name of an image file in (defun smiley-update-cache () (setq smiley-cached-regexp-alist nil) - (dolist (elt (if (symbolp smiley-regexp-alist) - (symbol-value smiley-regexp-alist) - smiley-regexp-alist)) - (let ((types gnus-smiley-file-types) - file type) - (while (and (not file) - (setq type (pop types))) - (unless (file-exists-p - (setq file (expand-file-name (concat (nth 2 elt) "." type) - smiley-data-directory))) - (setq file nil))) - (when type - (let ((image (gnus-create-image file (intern type) nil - :ascent 'center))) - (when image - (push (list (car elt) (cadr elt) image) - smiley-cached-regexp-alist))))))) + (if (eq smiley-style 'emoji) + (setq smiley-cached-regexp-alist smiley-emoji-regexp-alist) + (dolist (elt (if (symbolp smiley-regexp-alist) + (symbol-value smiley-regexp-alist) + smiley-regexp-alist)) + (let ((types gnus-smiley-file-types) + file type) + (while (and (not file) + (setq type (pop types))) + (unless (file-exists-p + (setq file (expand-file-name (concat (nth 2 elt) "." type) + smiley-data-directory))) + (setq file nil))) + (when type + (let ((image (gnus-create-image file (intern type) nil + :ascent 'center))) + (when image + (push (list (car elt) (cadr elt) image) + smiley-cached-regexp-alist)))))))) ;; Not implemented: ;; (defvar smiley-mouse-map @@ -193,8 +223,15 @@ A list of images is returned." (when image (push image images) (gnus-add-wash-type 'smiley) - (gnus-add-image 'smiley image) - (gnus-put-image image string 'smiley)))) + (if (symbolp image) + (progn + (gnus-add-image 'smiley image) + (gnus-put-image image string 'smiley)) + ;; This is a string, but mark the property for + ;; deletion if the washing method is switched off. + (insert (propertize string + 'display image + 'gnus-image-category 'smiley)))))) images)))) ;;;###autoload diff --git a/lisp/gnus/smime.el b/lisp/gnus/smime.el index fe6daf6b037..eb27fee88ce 100644 --- a/lisp/gnus/smime.el +++ b/lisp/gnus/smime.el @@ -174,8 +174,9 @@ and the files themselves should be in PEM format." (eq 0 (call-process "openssl" nil nil nil "version")) (error nil)) "openssl") - "Name of OpenSSL binary." - :type 'string + "Name of OpenSSL binary or nil if none." + :type '(choice string + (const :tag "none" nil)) :group 'smime) ;; OpenSSL option to select the encryption cipher @@ -185,6 +186,9 @@ and the files themselves should be in PEM format." :version "22.1" :type '(choice (const :tag "Triple DES" "-des3") (const :tag "DES" "-des") + (const :tag "AES 256 bits" "-aes256") + (const :tag "AES 192 bits" "-aes192") + (const :tag "AES 128 bits" "-aes128") (const :tag "RC2 40 bits" "-rc2-40") (const :tag "RC2 64 bits" "-rc2-64") (const :tag "RC2 128 bits" "-rc2-128")) diff --git a/lisp/gnus/spam-stat.el b/lisp/gnus/spam-stat.el index 3da45a2b623..bf593865d72 100644 --- a/lisp/gnus/spam-stat.el +++ b/lisp/gnus/spam-stat.el @@ -4,7 +4,7 @@ ;; Author: Alex Schroeder <alex@gnu.org> ;; Keywords: network -;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?SpamStat +;; URL: https://www.emacswiki.org/cgi-bin/wiki.pl?SpamStat ;; This file is part of GNU Emacs. diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index 5632bdaf250..96a7da2313c 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -579,7 +579,7 @@ This must be a list. For example, `(\"-C\" \"configfile\")'." (defcustom spam-spamassassin-positive-spam-flag-header "YES" "The regex on `spam-spamassassin-spam-flag-header' for positive spam identification." - :type 'string + :type 'regexp :group 'spam-spamassassin) (defcustom spam-spamassassin-spam-status-header "X-Spam-Status" |