>From 12185a4cf37be07e491d5003f1c88cd8499bab5f Mon Sep 17 00:00:00 2001 From: Manuel Giraud Date: Mon, 24 Jan 2022 17:29:13 +0100 Subject: [PATCH] a thread for Gnus fetching. --- lisp/gnus/gnus-demon.el | 6 +- lisp/gnus/gnus-group.el | 117 +++++++++++++++++++------------------ lisp/gnus/gnus-int.el | 41 +++++++------ lisp/gnus/gnus-search.el | 121 +++++++++++++++++++-------------------- lisp/gnus/gnus-sum.el | 61 ++++++++++---------- lisp/gnus/nnselect.el | 85 ++++++++++++++------------- 6 files changed, 215 insertions(+), 216 deletions(-) diff --git a/lisp/gnus/gnus-demon.el b/lisp/gnus/gnus-demon.el index d9da8529eb..c14a10eb78 100644 --- a/lisp/gnus/gnus-demon.el +++ b/lisp/gnus/gnus-demon.el @@ -70,8 +70,8 @@ gnus-demon-timestep (defvar gnus-demon-timers nil "Plist of idle timers which are running.") -(defvar gnus-inhibit-demon nil - "If non-nil, no daemonic function will be run.") +(defvar gnus-fetching-mutex) +(make-obsolete-variable 'gnus-inhibit-demon nil "29.0.50") ;;; Functions. @@ -98,7 +98,7 @@ gnus-demon-run-callback If not, and a TIME is given, restart a new idle timer, so FUNC can be called at the next opportunity. Such a special idle run is marked with SPECIAL." - (unless gnus-inhibit-demon + (with-mutex gnus-fetching-mutex (cl-block run-callback (when (eq idle t) (setq idle 0.001)) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index d3a94e9f4e..769f843547 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -500,7 +500,7 @@ gnus-tmp-subscribed (defvar gnus-tmp-summary-live) (defvar gnus-tmp-user-defined) -(defvar gnus-inhibit-demon) +(defvar gnus-fetching-mutex (make-mutex "Gnus is fetching")) (defvar gnus-pick-mode) (defvar gnus-tmp-marked-mark) (defvar gnus-tmp-number-of-unread) @@ -4185,6 +4185,31 @@ gnus-activate-all-groups (gnus-activate-foreign-newsgroups level)) (gnus-group-get-new-news))) +(defun gnus-group-get-new-news-1 (arg one-level) + (with-mutex gnus-fetching-mutex + (let (;; Binding this variable will inhibit multiple fetchings + ;; of the same mail source. + (nnmail-fetched-sources (list t))) + (gnus-run-hooks 'gnus-get-top-new-news-hook) + (gnus-run-hooks 'gnus-get-new-news-hook) + + ;; 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) + + ;; If the user wants it, we scan for new groups. + (when (eq gnus-check-new-newsgroups 'always) + (gnus-find-new-newsgroups)) + + (gnus-check-reasonable-setup) + (gnus-run-hooks 'gnus-after-getting-new-news-hook) + (gnus-group-list-groups (and (numberp arg) arg)) + (when gnus-group-use-permanent-levels + (setq gnus-group-use-permanent-levels (gnus-group-default-level arg)))))) + (defun gnus-group-get-new-news (&optional arg one-level) "Get newly arrived articles. If ARG is a number, it specifies which levels you are interested in @@ -4194,29 +4219,7 @@ gnus-group-get-new-news otherwise all levels below ARG will be scanned too." (interactive "P" gnus-group-mode) (require 'nnmail) - (let ((gnus-inhibit-demon t) - ;; Binding this variable will inhibit multiple fetchings - ;; of the same mail source. - (nnmail-fetched-sources (list t))) - (gnus-run-hooks 'gnus-get-top-new-news-hook) - (gnus-run-hooks 'gnus-get-new-news-hook) - - ;; 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) - - ;; If the user wants it, we scan for new groups. - (when (eq gnus-check-new-newsgroups 'always) - (gnus-find-new-newsgroups)) - - (gnus-check-reasonable-setup) - (gnus-run-hooks 'gnus-after-getting-new-news-hook) - (gnus-group-list-groups (and (numberp arg) arg)) - (when gnus-group-use-permanent-levels - (setq gnus-group-use-permanent-levels (gnus-group-default-level arg))))) + (make-thread #'(lambda () (gnus-group-get-new-news-1 arg one-level)))) (defun gnus-group-get-new-news-this-group (&optional n dont-scan) "Check for newly arrived news in the current group (and the N-1 next groups). @@ -4229,42 +4232,42 @@ gnus-group-get-new-news-this-group (beg (unless n (point-marker))) group method - (gnus-inhibit-demon t) ;; Binding this variable will inhibit multiple fetchings ;; of the same mail source. (nnmail-fetched-sources (list t))) - (gnus-run-hooks 'gnus-get-new-news-hook) - (while (setq group (pop groups)) - (gnus-group-remove-mark group) - ;; Bypass any previous denials from the server. - (gnus-remove-denial (setq method (gnus-find-method-for-group group))) - (if (if (and (not dont-scan) - ;; Prefer request-group-scan if the backend supports it. - (gnus-check-backend-function 'request-group-scan group)) - (progn - ;; Ensure that the server is already open. - (gnus-activate-group group nil nil method) - (gnus-request-group-scan group (gnus-get-info group))) - (gnus-activate-group group (if dont-scan nil 'scan) nil method)) - (let ((info (gnus-get-info group)) - (active (gnus-active group))) - (when info - (gnus-request-update-info info method)) - (gnus-get-unread-articles-in-group info active) - (unless (gnus-virtual-group-p group) - (gnus-close-group group)) - (when gnus-agent - (gnus-agent-save-group-info - method (gnus-group-real-name group) active)) - (gnus-group-update-group group nil t)) - (gnus-error 3 "%s error: %s" group (gnus-status-message group)))) - (gnus-run-hooks 'gnus-after-getting-new-news-hook) - (when beg - (goto-char beg)) - (when gnus-goto-next-group-when-activating - (gnus-group-next-unread-group 1 t)) - (gnus-group-position-point) - ret)) + (with-mutex gnus-fetching-mutex + (gnus-run-hooks 'gnus-get-new-news-hook) + (while (setq group (pop groups)) + (gnus-group-remove-mark group) + ;; Bypass any previous denials from the server. + (gnus-remove-denial (setq method (gnus-find-method-for-group group))) + (if (if (and (not dont-scan) + ;; Prefer request-group-scan if the backend supports it. + (gnus-check-backend-function 'request-group-scan group)) + (progn + ;; Ensure that the server is already open. + (gnus-activate-group group nil nil method) + (gnus-request-group-scan group (gnus-get-info group))) + (gnus-activate-group group (if dont-scan nil 'scan) nil method)) + (let ((info (gnus-get-info group)) + (active (gnus-active group))) + (when info + (gnus-request-update-info info method)) + (gnus-get-unread-articles-in-group info active) + (unless (gnus-virtual-group-p group) + (gnus-close-group group)) + (when gnus-agent + (gnus-agent-save-group-info + method (gnus-group-real-name group) active)) + (gnus-group-update-group group nil t)) + (gnus-error 3 "%s error: %s" group (gnus-status-message group)))) + (gnus-run-hooks 'gnus-after-getting-new-news-hook) + (when beg + (goto-char beg)) + (when gnus-goto-next-group-when-activating + (gnus-group-next-unread-group 1 t)) + (gnus-group-position-point) + ret))) (defun gnus-group-describe-group (force &optional group) "Display a description of the current newsgroup." diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index f00f2a0d04..256f13e7c0 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -755,21 +755,20 @@ gnus-request-expunge-group (nth 1 gnus-command-method)))) (defvar mail-source-plugged) -(defvar gnus-inhibit-demon) (defun gnus-request-scan (group command-method) "Request a SCAN being performed in GROUP from COMMAND-METHOD. If GROUP is nil, all groups on COMMAND-METHOD are scanned." (let ((gnus-command-method (if group (gnus-find-method-for-group group) command-method)) - (gnus-inhibit-demon t) (mail-source-plugged gnus-plugged)) - (when (or gnus-plugged - (not (gnus-agent-method-p gnus-command-method))) - (setq gnus-internal-registry-spool-current-method gnus-command-method) - (funcall (gnus-get-function gnus-command-method 'request-scan) - (and group (gnus-group-real-name group)) - (nth 1 gnus-command-method))))) + (with-mutex gnus-fetching-mutex + (when (or gnus-plugged + (not (gnus-agent-method-p gnus-command-method))) + (setq gnus-internal-registry-spool-current-method gnus-command-method) + (funcall (gnus-get-function gnus-command-method 'request-scan) + (and group (gnus-group-real-name group)) + (nth 1 gnus-command-method)))))) (defun gnus-request-update-info (info command-method) (when (gnus-check-backend-function @@ -812,18 +811,18 @@ gnus-request-expire-articles ;; expired here. (articles (delq nil (mapcar (lambda (n) (and (>= n 0) n)) articles))) - (gnus-inhibit-demon t) (not-deleted (funcall (gnus-get-function gnus-command-method 'request-expire-articles) articles (gnus-group-real-name group) (nth 1 gnus-command-method) force))) - (when (and gnus-agent - (gnus-agent-method-p gnus-command-method)) - (let ((expired-articles (gnus-sorted-difference articles not-deleted))) - (when expired-articles - (gnus-agent-expire expired-articles group 'force)))) - not-deleted)) + (with-mutex gnus-fetching-mutex + (when (and gnus-agent + (gnus-agent-method-p gnus-command-method)) + (let ((expired-articles (gnus-sorted-difference articles not-deleted))) + (when expired-articles + (gnus-agent-expire expired-articles group 'force)))) + not-deleted))) (defun gnus-request-move-article (article group _server accept-function &optional last move-is-internal) @@ -928,13 +927,13 @@ gnus-request-rename-group (defun gnus-close-backends () ;; Send a close request to all backends that support such a request. (let ((methods gnus-valid-select-methods) - (gnus-inhibit-demon t) func gnus-command-method) - (while (setq gnus-command-method (pop methods)) - (when (fboundp (setq func (intern - (concat (car gnus-command-method) - "-request-close")))) - (funcall func))))) + (with-mutex gnus-fetching-mutex + (while (setq gnus-command-method (pop methods)) + (when (fboundp (setq func (intern + (concat (car gnus-command-method) + "-request-close")))) + (funcall func)))))) (defun gnus-asynchronous-p (command-method) (let ((func (gnus-get-function command-method 'asynchronous-p t))) diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index bf88abae76..572a2b92c1 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el @@ -87,7 +87,6 @@ (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: @@ -1015,70 +1014,70 @@ gnus-search-run-search 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) - (gnus-message 7 "Opening server %s" server) - (gnus-open-server srv) - ;; 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)) - - ;; A bit of backward-compatibility slash convenience: if the - ;; query string doesn't start with any known IMAP search - ;; keyword, assume it is a "TEXT" search. - (unless (or (eql ?\( (aref q-string 0)) - (and (string-match "\\`[^[:blank:]]+" q-string) - (memql (intern-soft (downcase - (match-string 0 q-string))) - gnus-search-imap-search-keys))) - (setq q-string (concat "TEXT " q-string))) - - ;; 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) (= 0 (length artlist)))) - (when (nnimap-change-group - (gnus-group-short-name group) server) - (with-current-buffer (nnimap-buffer) - (gnus-message 7 "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)))) - (gnus-message 7 "Searching %s...done" group)))) - (nreverse artlist)))) + (with-mutex gnus-fetching-mutex + (gnus-message 7 "Opening server %s" server) + (gnus-open-server srv) + ;; 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)) + + ;; A bit of backward-compatibility slash convenience: if the + ;; query string doesn't start with any known IMAP search + ;; keyword, assume it is a "TEXT" search. + (unless (or (eql ?\( (aref q-string 0)) + (and (string-match "\\`[^[:blank:]]+" q-string) + (memql (intern-soft (downcase + (match-string 0 q-string))) + gnus-search-imap-search-keys))) + (setq q-string (concat "TEXT " q-string))) + + ;; 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) (= 0 (length artlist)))) + (when (nnimap-change-group + (gnus-group-short-name group) server) + (with-current-buffer (nnimap-buffer) + (gnus-message 7 "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)))) + (gnus-message 7 "Searching %s...done" group)))) + (nreverse artlist))))) (cl-defmethod gnus-search-imap-search-command ((engine gnus-search-imap) (query string)) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 8fb07d5905..4894402516 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -30,7 +30,6 @@ tool-bar-mode (defvar gnus-category-predicate-alist) (defvar gnus-category-predicate-cache) (defvar gnus-inhibit-article-treatments) -(defvar gnus-inhibit-demon) (defvar gnus-tmp-article-number) (defvar gnus-tmp-closing-bracket) (defvar gnus-tmp-current) @@ -8713,17 +8712,17 @@ gnus-summary-limit-include-dormant (defun gnus-summary-include-articles (articles) "Fetch the headers for ARTICLES and then display the summary lines." - (let ((gnus-inhibit-demon t) - (gnus-agent nil) + (let ((gnus-agent nil) (gnus-read-all-available-headers t)) - (setq gnus-newsgroup-headers - (cl-merge - 'list gnus-newsgroup-headers - (gnus-fetch-headers articles nil t) - 'gnus-article-sort-by-number)) - (setq gnus-newsgroup-articles - (gnus-sorted-nunion gnus-newsgroup-articles articles)) - (gnus-summary-limit (append articles gnus-newsgroup-limit)))) + (with-mutex gnus-fetching-mutex + (setq gnus-newsgroup-headers + (cl-merge + 'list gnus-newsgroup-headers + (gnus-fetch-headers articles nil t) + 'gnus-article-sort-by-number)) + (setq gnus-newsgroup-articles + (gnus-sorted-nunion gnus-newsgroup-articles articles)) + (gnus-summary-limit (append articles gnus-newsgroup-limit))))) (defun gnus-summary-limit-exclude-dormant () "Hide all dormant articles." @@ -9086,7 +9085,6 @@ gnus-summary-refer-thread (interactive "P" gnus-summary-mode) (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-search @@ -9116,25 +9114,26 @@ gnus-summary-refer-thread (* 2 limit) limit) t)))) article-ids new-unreads) - (when (listp new-headers) - (dolist (header new-headers) - (push (mail-header-number header) article-ids)) - (setq article-ids (nreverse article-ids)) - (setq new-unreads - (gnus-sorted-intersection gnus-newsgroup-unselected article-ids)) - (setq gnus-newsgroup-unselected - (gnus-sorted-ndifference gnus-newsgroup-unselected new-unreads)) - (setq gnus-newsgroup-unreads - (gnus-sorted-nunion gnus-newsgroup-unreads new-unreads)) - (setq gnus-newsgroup-headers - (gnus-delete-duplicate-headers - (cl-merge - 'list gnus-newsgroup-headers new-headers - 'gnus-article-sort-by-number))) - (setq gnus-newsgroup-articles - (gnus-sorted-nunion gnus-newsgroup-articles article-ids)) - (gnus-summary-limit-include-thread id gnus-refer-thread-limit-to-thread))) - (gnus-summary-show-thread)) + (with-mutex gnus-fetching-mutex + (when (listp new-headers) + (dolist (header new-headers) + (push (mail-header-number header) article-ids)) + (setq article-ids (nreverse article-ids)) + (setq new-unreads + (gnus-sorted-intersection gnus-newsgroup-unselected article-ids)) + (setq gnus-newsgroup-unselected + (gnus-sorted-ndifference gnus-newsgroup-unselected new-unreads)) + (setq gnus-newsgroup-unreads + (gnus-sorted-nunion gnus-newsgroup-unreads new-unreads)) + (setq gnus-newsgroup-headers + (gnus-delete-duplicate-headers + (cl-merge + 'list gnus-newsgroup-headers new-headers + 'gnus-article-sort-by-number))) + (setq gnus-newsgroup-articles + (gnus-sorted-nunion gnus-newsgroup-articles article-ids)) + (gnus-summary-limit-include-thread id gnus-refer-thread-limit-to-thread))) + (gnus-summary-show-thread))) (defun gnus-summary-open-group-with-article (message-id) "Open a group containing the article with the given MESSAGE-ID." diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index 205456a57d..2d09d62dce 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -61,7 +61,6 @@ nnselect ;;; Internal Variables: -(defvar gnus-inhibit-demon) (defvar gnus-message-group-art) ;; For future use @@ -316,53 +315,53 @@ nnselect-retrieve-headers (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)) + (let ((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)) + (with-mutex gnus-fetching-mutex + (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-head)) - (forward-line 1)))) - ((pred listp) - (dolist (novitem gnus-headers-retrieved-by) - (nnselect-add-novitem novitem))) - (_ (error "Unknown header type %s while requesting articles \ + (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)))))))))) + (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) -- 2.34.1