* async Gnus
@ 2022-01-24 16:58 Manuel Giraud
2022-01-25 17:29 ` Eric Abrahamsen
0 siblings, 1 reply; 9+ messages in thread
From: Manuel Giraud @ 2022-01-24 16:58 UTC (permalink / raw)
To: emacs-devel
[-- Attachment #1: Type: text/plain, Size: 419 bytes --]
Hi,
I'd like to have Gnus being able to fetch some mails (and news
obviously ;-) without freezing emacs completely. I'm currently
trying the attached dumb patch that so far seems to fly with a gnus
demon handler like this:
(gnus-demon-add-handler 'gnus-group-get-new-news 5 nil)
My questions are:
- Is this the right place to discuss Gnus dev?
- This patch seems too simple: what am I missing?
Best regards,
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-a-thread-for-Gnus-fetching.patch --]
[-- Type: text/x-patch, Size: 24093 bytes --]
From 12185a4cf37be07e491d5003f1c88cd8499bab5f Mon Sep 17 00:00:00 2001
From: Manuel Giraud <manuel@ledu-giraud.fr>
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
[-- Attachment #3: Type: text/plain, Size: 18 bytes --]
--
Manuel Giraud
^ permalink raw reply related [flat|nested] 9+ messages in thread
* Re: async Gnus
2022-01-24 16:58 async Gnus Manuel Giraud
@ 2022-01-25 17:29 ` Eric Abrahamsen
2022-01-26 10:05 ` Manuel Giraud
0 siblings, 1 reply; 9+ messages in thread
From: Eric Abrahamsen @ 2022-01-25 17:29 UTC (permalink / raw)
To: emacs-devel
Manuel Giraud <manuel@ledu-giraud.fr> writes:
> Hi,
>
> I'd like to have Gnus being able to fetch some mails (and news
> obviously ;-) without freezing emacs completely. I'm currently
> trying the attached dumb patch that so far seems to fly with a gnus
> demon handler like this:
>
> (gnus-demon-add-handler 'gnus-group-get-new-news 5 nil)
>
> My questions are:
>
> - Is this the right place to discuss Gnus dev?
Yes!
> - This patch seems too simple: what am I missing?
It's hard to say -- no one seems to know what to expect with threads.
The main issue I can see with your code is that it only uses a single
thread, which should mean (I haven't tested it) that it provides very
little speedup. All elisp execution happens in the main thread, the only
concurrency happens with network and process communication (maybe some
other stuff), so unless you're "layering" multiple process calls in
multiple threads, everything's going to happen more or less
consecutively anyway. I think you'd need one thread per Gnus server, so
that multiple connections to external servers (IMAP or NNTP or POP)
could do their thing concurrently.
All this is just my theoretical understanding of how threads work, mind
you. Have you seen a significant speedup with this patch?
Also, bug#49065 might have some relevant code you could refer to, I
think the author was trying to do something similar there.
Thanks,
Eric
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: async Gnus
2022-01-25 17:29 ` Eric Abrahamsen
@ 2022-01-26 10:05 ` Manuel Giraud
2022-01-26 13:10 ` Eli Zaretskii
0 siblings, 1 reply; 9+ messages in thread
From: Manuel Giraud @ 2022-01-26 10:05 UTC (permalink / raw)
To: Eric Abrahamsen; +Cc: emacs-devel
Eric Abrahamsen <eric@ericabrahamsen.net> writes:
> Manuel Giraud <manuel@ledu-giraud.fr> writes:
>
>> Hi,
Hi Eric,
>> I'd like to have Gnus being able to fetch some mails (and news
>> obviously ;-) without freezing emacs completely. I'm currently
>> trying the attached dumb patch that so far seems to fly with a gnus
>> demon handler like this:
>>
>> (gnus-demon-add-handler 'gnus-group-get-new-news 5 nil)
>>
>> My questions are:
>>
>> - Is this the right place to discuss Gnus dev?
>
> Yes!
Good!
>> - This patch seems too simple: what am I missing?
>
> It's hard to say -- no one seems to know what to expect with threads.
> The main issue I can see with your code is that it only uses a single
> thread, which should mean (I haven't tested it) that it provides very
> little speedup. All elisp execution happens in the main thread, the only
> concurrency happens with network and process communication (maybe some
> other stuff), so unless you're "layering" multiple process calls in
> multiple threads, everything's going to happen more or less
> consecutively anyway. I think you'd need one thread per Gnus server, so
> that multiple connections to external servers (IMAP or NNTP or POP)
> could do their thing concurrently.
>
> All this is just my theoretical understanding of how threads work, mind
> you. Have you seen a significant speedup with this patch?
I'm not looking for speedup I'm looking for being able to use Emacs as
usual while Gnus is fetching stuff. But you are right that this patch
does not achieve this: Emacs is still freezing from time to time and so
it is not really better than the default Gnus demon behaviour.
I'm suprprise: I thought that `make-thread' create a proper system
thread.
I'm digging into Gnus sources and also conclude that those threads
should appear at a deeper layer (maybe at the method request layer or
per Gnus server as you said). It would also permit concurrency between
methods (or servers).
I should also keep in mind that this could fallback to a non-threaded
method for arch that do not have them.
> Also, bug#49065 might have some relevant code you could refer to, I
> think the author was trying to do something similar there.
Thanks, I'll have a look at it!
--
Manuel Giraud
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: async Gnus
2022-01-26 10:05 ` Manuel Giraud
@ 2022-01-26 13:10 ` Eli Zaretskii
2022-01-26 14:58 ` Manuel Giraud
0 siblings, 1 reply; 9+ messages in thread
From: Eli Zaretskii @ 2022-01-26 13:10 UTC (permalink / raw)
To: Manuel Giraud; +Cc: eric, emacs-devel
> From: Manuel Giraud <manuel@ledu-giraud.fr>
> Date: Wed, 26 Jan 2022 11:05:43 +0100
> Cc: emacs-devel@gnu.org
>
> I'm suprprise: I thought that `make-thread' create a proper system
> thread.
It does. But we only let a single thread at a time to run the Lisp
interpreter. So if your thread runs a lot of Lisp, it will preempt
the main thread, and that means unresponsive Emacs.
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: async Gnus
2022-01-26 13:10 ` Eli Zaretskii
@ 2022-01-26 14:58 ` Manuel Giraud
2022-01-26 15:32 ` Thomas Fitzsimmons
0 siblings, 1 reply; 9+ messages in thread
From: Manuel Giraud @ 2022-01-26 14:58 UTC (permalink / raw)
To: Eli Zaretskii; +Cc: eric, emacs-devel
Eli Zaretskii <eliz@gnu.org> writes:
>> From: Manuel Giraud <manuel@ledu-giraud.fr>
>> Date: Wed, 26 Jan 2022 11:05:43 +0100
>> Cc: emacs-devel@gnu.org
>>
>> I'm suprprise: I thought that `make-thread' create a proper system
>> thread.
>
> It does. But we only let a single thread at a time to run the Lisp
> interpreter. So if your thread runs a lot of Lisp, it will preempt
> the main thread, and that means unresponsive Emacs.
Ok so, as Python, Emacs has a GIL. As Gnus seems to be an heavy user of
Lisp maybe my goal is inaccessible… I'll try to see what I end up with
anyway 😅
--
Manuel Giraud
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: async Gnus
2022-01-26 14:58 ` Manuel Giraud
@ 2022-01-26 15:32 ` Thomas Fitzsimmons
2022-01-26 16:36 ` Manuel Giraud
0 siblings, 1 reply; 9+ messages in thread
From: Thomas Fitzsimmons @ 2022-01-26 15:32 UTC (permalink / raw)
To: Manuel Giraud; +Cc: eric, Eli Zaretskii, emacs-devel
Hi Manuel,
Manuel Giraud <manuel@ledu-giraud.fr> writes:
> Eli Zaretskii <eliz@gnu.org> writes:
>
>>> From: Manuel Giraud <manuel@ledu-giraud.fr>
>>> Date: Wed, 26 Jan 2022 11:05:43 +0100
>>> Cc: emacs-devel@gnu.org
>>>
>>> I'm suprprise: I thought that `make-thread' create a proper system
>>> thread.
>>
>> It does. But we only let a single thread at a time to run the Lisp
>> interpreter. So if your thread runs a lot of Lisp, it will preempt
>> the main thread, and that means unresponsive Emacs.
>
> Ok so, as Python, Emacs has a GIL. As Gnus seems to be an heavy user of
> Lisp maybe my goal is inaccessible… I'll try to see what I end up with
> anyway 😅
Bug 49065 has a huge patch that, among other things, introduces a
background thread for gnus-group-get-new-news. It was never accepted
because the author didn't break the larger patch into smaller chunks for
review. Maybe you could start from that large patch, confirm the
asynchronous changes work for you, then separate out the
background-thread parts to submit.
Thomas
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: async Gnus
2022-01-26 15:32 ` Thomas Fitzsimmons
@ 2022-01-26 16:36 ` Manuel Giraud
2022-01-26 17:53 ` Eric Abrahamsen
0 siblings, 1 reply; 9+ messages in thread
From: Manuel Giraud @ 2022-01-26 16:36 UTC (permalink / raw)
To: Thomas Fitzsimmons; +Cc: eric, Eli Zaretskii, emacs-devel
Thomas Fitzsimmons <fitzsim@fitzsim.org> writes:
[...]
> Bug 49065 has a huge patch that, among other things, introduces a
> background thread for gnus-group-get-new-news. It was never accepted
> because the author didn't break the larger patch into smaller chunks for
> review. Maybe you could start from that large patch, confirm the
> asynchronous changes work for you, then separate out the
> background-thread parts to submit.
Yes, Eric point me to this patch too. It is a 8k lines beast but maybe I
could try this method. Thanks.
--
Manuel Giraud
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: async Gnus
2022-01-26 16:36 ` Manuel Giraud
@ 2022-01-26 17:53 ` Eric Abrahamsen
2022-02-01 16:26 ` Manuel Giraud
0 siblings, 1 reply; 9+ messages in thread
From: Eric Abrahamsen @ 2022-01-26 17:53 UTC (permalink / raw)
To: Manuel Giraud; +Cc: emacs-devel
Manuel Giraud <manuel@ledu-giraud.fr> writes:
> thomas Fitzsimmons <fitzsim@fitzsim.org> writes:
>
> [...]
>
>> Bug 49065 has a huge patch that, among other things, introduces a
>> background thread for gnus-group-get-new-news. It was never accepted
>> because the author didn't break the larger patch into smaller chunks for
>> review. Maybe you could start from that large patch, confirm the
>> asynchronous changes work for you, then separate out the
>> background-thread parts to submit.
>
> Yes, Eric point me to this patch too. It is a 8k lines beast but maybe I
> could try this method. Thanks.
It would be great if you could make use of that somehow -- I don't think
anyone's had the wherewithal to actually sit down and read through it.
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: async Gnus
2022-01-26 17:53 ` Eric Abrahamsen
@ 2022-02-01 16:26 ` Manuel Giraud
0 siblings, 0 replies; 9+ messages in thread
From: Manuel Giraud @ 2022-02-01 16:26 UTC (permalink / raw)
To: Eric Abrahamsen; +Cc: emacs-devel
[-- Attachment #1: Type: text/plain, Size: 772 bytes --]
Hi,
So I've study the patch of bug#49065 a bit. AFAIU, the dick.r.chiang's
approach is to introduce Emacs threads in the `gnus-get-unread-articles'
function. As `gnus-get-unread-articles' is relatively high in the call
stack, it has the advantage of working with all Gnus methods… but I'd
like to try a different approach.
As eventually Gnus ends up running some processes, I'd like to try to
register all the work that Gnus does into those processes' sentinels. As
I'm an "nnml/mail-sources" user so I'd like to try here first.
For this goal here is my first patch. There is nothing async for the
moment: all this patch does is that now each call of `mail-source-fetch'
will eventually creates its unique crash box to temporarily stores its
mails.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-uniquify-mail-source-crash-box-on-each-different-mai.patch --]
[-- Type: text/x-patch, Size: 20303 bytes --]
From 734b13491965ae85907568a3d392e4fdb74a675a Mon Sep 17 00:00:00 2001
From: Manuel Giraud <manuel@ledu-giraud.fr>
Date: Wed, 26 Jan 2022 16:00:41 +0100
Subject: [PATCH] uniquify mail-source-crash-box on each different mail-source
fetcher.
---
lisp/gnus/mail-source.el | 386 ++++++++++++++++++++-------------------
1 file changed, 202 insertions(+), 184 deletions(-)
diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el
index 5d0c0e2654..4498ea13f6 100644
--- a/lisp/gnus/mail-source.el
+++ b/lisp/gnus/mail-source.el
@@ -238,10 +238,12 @@ mail-source-flash
"If non-nil, flash periodically when mail is available."
:type 'boolean)
-(defcustom mail-source-crash-box "~/.emacs-mail-crash-box"
- "File where mail will be stored while processing it."
+(defcustom mail-source-crash-box-prefix "~/.emacs-mail-crash-box-"
+ "Prefix of files where mail will be stored while processing it."
:type 'file)
+(make-obsolete-variable 'mail-source-crash-box 'mail-source-crash-box-prefix "29.1")
+
(defcustom mail-source-directory message-directory
"Directory where incoming mail source files (if any) will be stored."
:type 'directory)
@@ -518,6 +520,18 @@ mail-source-value
(autoload 'nnheader-message "nnheader")
+(defun mail-source-fetcher (source)
+ (cadr (assq (car source) mail-source-fetcher-alist)))
+
+(defun mail-source-crash-box ()
+ (make-temp-name mail-source-crash-box-prefix))
+
+(defun mail-source-existing-crash-boxes ()
+ (let ((directory (file-name-directory mail-source-crash-box-prefix))
+ (partial (file-name-nondirectory mail-source-crash-box-prefix)))
+ (mapcar #'(lambda (name) (file-name-concat directory name))
+ (file-name-all-completions partial directory))))
+
(defun mail-source-fetch (source callback &optional method)
"Fetch mail from SOURCE and call CALLBACK zero or more times.
CALLBACK will be called with the name of the file where (some of)
@@ -536,21 +550,20 @@ mail-source-fetch
(format "%s: " method)
"")
(car source)))
- (let ((function (cadr (assq (car source) mail-source-fetcher-alist)))
+ (let ((fetcher (mail-source-fetcher source))
(found 0))
- (unless function
+ (unless fetcher
(error "%S is an invalid mail source specification" source))
- ;; If there's anything in the crash box, we do it first.
- (when (file-exists-p mail-source-crash-box)
- (message "Processing mail from %s..." mail-source-crash-box)
- (setq found (mail-source-callback
- callback mail-source-crash-box))
- (mail-source-delete-crash-box))
+ ;; If there's anything in some crash boxes, we do it first.
+ (dolist (box (mail-source-existing-crash-boxes))
+ (message "Processing mail from %s..." box)
+ (setq found (mail-source-callback callback box box))
+ (mail-source-delete-crash-box box))
(+ found
(if (or debug-on-quit debug-on-error)
- (funcall function source callback)
+ (funcall fetcher source callback)
(condition-case err
- (funcall function source callback)
+ (funcall fetcher source callback)
(error
(gnus-error
5
@@ -596,24 +609,24 @@ mail-source-delete-old-incoming
t))
(delete-file ffile))))))
-(defun mail-source-callback (callback info)
+(defun mail-source-callback (callback info crash-box)
"Call CALLBACK on the mail file. Pass INFO on to CALLBACK."
- (if (or (not (file-exists-p mail-source-crash-box))
+ (if (or (not (file-exists-p crash-box))
(zerop (file-attribute-size
- (file-attributes mail-source-crash-box))))
+ (file-attributes crash-box))))
(progn
- (when (file-exists-p mail-source-crash-box)
- (delete-file mail-source-crash-box))
+ (when (file-exists-p crash-box)
+ (delete-file crash-box))
0)
- (funcall callback mail-source-crash-box info)))
+ (funcall callback crash-box info)))
(defvar mail-source-incoming-last-checked-time nil)
-(defun mail-source-delete-crash-box ()
- (when (file-exists-p mail-source-crash-box)
+(defun mail-source-delete-crash-box (crash-box)
+ (when (file-exists-p crash-box)
;; Delete or move the incoming mail out of the way.
(if (eq mail-source-delete-incoming t)
- (delete-file mail-source-crash-box)
+ (delete-file crash-box)
(let ((incoming
(make-temp-file
(expand-file-name
@@ -621,7 +634,7 @@ mail-source-delete-crash-box
mail-source-directory))))
(unless (file-exists-p (file-name-directory incoming))
(make-directory (file-name-directory incoming) t))
- (rename-file mail-source-crash-box incoming t)
+ (rename-file crash-box incoming t)
;; remove old incoming files?
(when (natnump mail-source-delete-incoming)
;; Don't check for old incoming files more than once per day to
@@ -750,17 +763,18 @@ mail-source-call-script
(defun mail-source-fetch-file (source callback)
"Fetcher for single-file sources."
(mail-source-bind (file source)
- (mail-source-run-script
- 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 `((?t . ,mail-source-crash-box)))
- (mail-source-delete-crash-box))
- 0))))
+ (let ((crash-box (mail-source-crash-box)))
+ (mail-source-run-script
+ prescript `((?t . ,crash-box))
+ prescript-delay)
+ (let ((mail-source-string (format "file:%s" path)))
+ (if (mail-source-movemail path crash-box)
+ (prog1
+ (mail-source-callback callback path crash-box)
+ (mail-source-run-script
+ postscript `((?t . ,crash-box)))
+ (mail-source-delete-crash-box crash-box))
+ 0)))))
(defun mail-source-fetch-directory (source callback)
"Fetcher for directory sources."
@@ -768,92 +782,94 @@ mail-source-fetch-directory
(mail-source-run-script
prescript `((?t . ,path)) prescript-delay)
(let ((found 0)
- (mail-source-string (format "directory:%s" path)))
+ (mail-source-string (format "directory:%s" path))
+ (crash-box (mail-source-crash-box)))
(dolist (file (directory-files
path t (concat (regexp-quote suffix) "$")))
(when (and (file-regular-p file)
(funcall predicate file)
- (mail-source-movemail file mail-source-crash-box))
- (cl-incf found (mail-source-callback callback file))
+ (mail-source-movemail file crash-box))
+ (cl-incf found (mail-source-callback callback file crash-box))
(mail-source-run-script postscript `((?t . ,path)))
- (mail-source-delete-crash-box)))
+ (mail-source-delete-crash-box crash-box)))
found)))
(defun mail-source-fetch-pop (source callback)
"Fetcher for single-file sources."
(mail-source-bind (pop source)
- ;; fixme: deal with stream type in format specs
- (mail-source-run-script
- 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))
- (mail-source-string (format "pop:%s@%s" user server))
- (process-environment (if server
- (cons (concat "MAILHOST=" server)
- process-environment)
- process-environment))
- result)
- (when (eq authentication 'password)
- (setq password
- (or password
- (cdr (assoc from mail-source-password-cache))
- (read-passwd
- (format "Password for %s at %s: " user server)))))
- (setq result
- (cond
- (program
- (mail-source-fetch-with-program
- (format-spec
- program
- `((?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.
- (t
- (require 'pop3)
- (dlet ((pop3-password password)
- (pop3-maildrop user)
- (pop3-mailhost server)
- (pop3-port port)
- (pop3-authentication-scheme
- (if (eq authentication 'apop) 'apop 'pass))
- (pop3-stream-type stream)
- (pop3-leave-mail-on-server leave))
- (if (or debug-on-quit debug-on-error)
- (save-excursion (pop3-movemail mail-source-crash-box))
- (condition-case err
- (save-excursion (pop3-movemail mail-source-crash-box))
- (error
- ;; We nix out the password in case the error
- ;; was because of a wrong password being given.
- (setq mail-source-password-cache
- (delq (assoc from mail-source-password-cache)
- mail-source-password-cache))
- (signal (car err) (cdr err)))))))))
- (if result
- (progn
- (when (eq authentication 'password)
- (unless (assoc from mail-source-password-cache)
- (push (cons from password) mail-source-password-cache)))
- (prog1
- (mail-source-callback callback server)
- ;; Update display-time's mail flag, if relevant.
- (if (equal source mail-source-primary-source)
- (setq mail-source-new-mail-available nil))
- (mail-source-run-script
- postscript
- `((?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.
- (setq mail-source-password-cache
- (delq (assoc from mail-source-password-cache)
- mail-source-password-cache))
- 0))))
+ (let ((crash-box (mail-source-crash-box)))
+ ;; fixme: deal with stream type in format specs
+ (mail-source-run-script
+ prescript
+ `((?p . ,password) (?t . ,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))
+ (process-environment (if server
+ (cons (concat "MAILHOST=" server)
+ process-environment)
+ process-environment))
+ result)
+ (when (eq authentication 'password)
+ (setq password
+ (or password
+ (cdr (assoc from mail-source-password-cache))
+ (read-passwd
+ (format "Password for %s at %s: " user server)))))
+ (setq result
+ (cond
+ (program
+ (mail-source-fetch-with-program
+ (format-spec
+ program
+ `((?p . ,password) (?t . ,crash-box)
+ (?s . ,server) (?P . ,port) (?u . ,user)))))
+ (function
+ (funcall function crash-box))
+ ;; The default is to use pop3.el.
+ (t
+ (require 'pop3)
+ (dlet ((pop3-password password)
+ (pop3-maildrop user)
+ (pop3-mailhost server)
+ (pop3-port port)
+ (pop3-authentication-scheme
+ (if (eq authentication 'apop) 'apop 'pass))
+ (pop3-stream-type stream)
+ (pop3-leave-mail-on-server leave))
+ (if (or debug-on-quit debug-on-error)
+ (save-excursion (pop3-movemail crash-box))
+ (condition-case err
+ (save-excursion (pop3-movemail crash-box))
+ (error
+ ;; We nix out the password in case the error
+ ;; was because of a wrong password being given.
+ (setq mail-source-password-cache
+ (delq (assoc from mail-source-password-cache)
+ mail-source-password-cache))
+ (signal (car err) (cdr err)))))))))
+ (if result
+ (progn
+ (when (eq authentication 'password)
+ (unless (assoc from mail-source-password-cache)
+ (push (cons from password) mail-source-password-cache)))
+ (prog1
+ (mail-source-callback callback server crash-box)
+ ;; Update display-time's mail flag, if relevant.
+ (if (equal source mail-source-primary-source)
+ (setq mail-source-new-mail-available nil))
+ (mail-source-run-script
+ postscript
+ `((?p . ,password) (?t . ,crash-box)
+ (?s . ,server) (?P . ,port) (?u . ,user)))
+ (mail-source-delete-crash-box crash-box)))
+ ;; We nix out the password in case the error
+ ;; was because of a wrong password being given.
+ (setq mail-source-password-cache
+ (delq (assoc from mail-source-password-cache)
+ mail-source-password-cache))
+ 0)))))
(defun mail-source-check-pop (source)
"Check whether there is new mail."
@@ -1001,6 +1017,7 @@ mail-source-fetch-maildir
"Fetcher for maildir sources."
(mail-source-bind (maildir source)
(let ((found 0)
+ (crash-box (mail-source-crash-box))
mail-source-string)
(unless (string-match "/$" path)
(setq path (concat path "/")))
@@ -1011,12 +1028,12 @@ mail-source-fetch-maildir
(when (and (not (file-directory-p file))
(not (if function
;; `function' should return nil if successful.
- (funcall function file mail-source-crash-box)
+ (funcall function file crash-box)
(let ((coding-system-for-write
mm-text-coding-system)
(coding-system-for-read
mm-text-coding-system))
- (with-temp-file mail-source-crash-box
+ (with-temp-file crash-box
(insert-file-contents file)
(goto-char (point-min))
;;; ;; Unix mail format
@@ -1031,8 +1048,8 @@ mail-source-fetch-maildir
(insert "\001\001\001\001\n"))
(delete-file file)
nil))))
- (cl-incf found (mail-source-callback callback file))
- (mail-source-delete-crash-box)))))
+ (cl-incf found (mail-source-callback callback file crash-box))
+ (mail-source-delete-crash-box crash-box)))))
found)))
(autoload 'imap-open "imap")
@@ -1058,78 +1075,79 @@ mail-source-imap-file-coding-system
(defun mail-source-fetch-imap (source callback)
"Fetcher for imap sources."
(mail-source-bind (imap source)
- (mail-source-run-script
- 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)
- (buf (generate-new-buffer " *imap source*"))
- (mail-source-string (format "imap:%s:%s" server mailbox))
- (imap-shell-program (or (list program) imap-shell-program))
- remove)
- (if (and (imap-open server port stream authentication buf)
- (imap-authenticate
- user (or (cdr (assoc from mail-source-password-cache))
- password)
- buf))
- (let ((mailbox-list (if (listp mailbox) mailbox (list mailbox))))
- (dolist (mailbox mailbox-list)
- (when (imap-mailbox-select mailbox nil buf)
- (let ((coding-system-for-write mail-source-imap-file-coding-system)
- str)
- (message "Fetching from %s..." mailbox)
- (with-temp-file mail-source-crash-box
- ;; Avoid converting 8-bit chars from inserted strings to
- ;; multibyte.
- (mm-disable-multibyte)
- ;; remember password
- (with-current-buffer buf
- (when (and imap-password
- (not (member (cons from imap-password)
- mail-source-password-cache)))
- (push (cons from imap-password) mail-source-password-cache)))
- ;; if predicate is nil, use all uids
- (dolist (uid (imap-search (or predicate "1:*") buf))
- (when (setq str
- (if (imap-capability 'IMAP4rev1 buf)
- (caddar (imap-fetch uid "BODY.PEEK[]"
- 'BODYDETAIL nil buf))
- (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf)))
- (push uid remove)
- (insert "From imap " (current-time-string) "\n")
- (save-excursion
- (insert str "\n\n"))
- (while (let ((case-fold-search nil))
- (re-search-forward "^From " nil t))
- (replace-match ">From "))
- (goto-char (point-max))))
- (nnheader-ms-strip-cr))
- (cl-incf found (mail-source-callback callback server))
- (mail-source-delete-crash-box)
- (when (and remove fetchflag)
- (setq remove (nreverse remove))
- (imap-message-flags-add
- (imap-range-to-message-set (gnus-compress-sequence remove))
- fetchflag nil buf))
- (if dontexpunge
- (imap-mailbox-unselect buf)
- (imap-mailbox-close nil buf)))))
- (imap-close buf))
- (imap-close buf)
- ;; We nix out the password in case the error
- ;; was because of a wrong password being given.
- (setq mail-source-password-cache
- (delq (assoc from mail-source-password-cache)
- mail-source-password-cache))
- (error "IMAP error: %s" (imap-error-text buf)))
- (kill-buffer buf)
+ (let ((crash-box (mail-source-crash-box)))
(mail-source-run-script
- postscript
- `((?p . ,password) (?t . ,mail-source-crash-box)
- (?s . ,server) (?P . ,port) (?u . ,user)))
- found)))
+ prescript
+ `((?p . ,password) (?t . ,crash-box)
+ (?s . ,server) (?P . ,port) (?u . ,user))
+ prescript-delay)
+ (let ((from (format "%s:%s:%s" server user port))
+ (found 0)
+ (buf (generate-new-buffer " *imap source*"))
+ (mail-source-string (format "imap:%s:%s" server mailbox))
+ (imap-shell-program (or (list program) imap-shell-program))
+ remove)
+ (if (and (imap-open server port stream authentication buf)
+ (imap-authenticate
+ user (or (cdr (assoc from mail-source-password-cache))
+ password)
+ buf))
+ (let ((mailbox-list (if (listp mailbox) mailbox (list mailbox))))
+ (dolist (mailbox mailbox-list)
+ (when (imap-mailbox-select mailbox nil buf)
+ (let ((coding-system-for-write mail-source-imap-file-coding-system)
+ str)
+ (message "Fetching from %s..." mailbox)
+ (with-temp-file crash-box
+ ;; Avoid converting 8-bit chars from inserted strings to
+ ;; multibyte.
+ (mm-disable-multibyte)
+ ;; remember password
+ (with-current-buffer buf
+ (when (and imap-password
+ (not (member (cons from imap-password)
+ mail-source-password-cache)))
+ (push (cons from imap-password) mail-source-password-cache)))
+ ;; if predicate is nil, use all uids
+ (dolist (uid (imap-search (or predicate "1:*") buf))
+ (when (setq str
+ (if (imap-capability 'IMAP4rev1 buf)
+ (caddar (imap-fetch uid "BODY.PEEK[]"
+ 'BODYDETAIL nil buf))
+ (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf)))
+ (push uid remove)
+ (insert "From imap " (current-time-string) "\n")
+ (save-excursion
+ (insert str "\n\n"))
+ (while (let ((case-fold-search nil))
+ (re-search-forward "^From " nil t))
+ (replace-match ">From "))
+ (goto-char (point-max))))
+ (nnheader-ms-strip-cr))
+ (cl-incf found (mail-source-callback callback server crash-box))
+ (mail-source-delete-crash-box crash-box)
+ (when (and remove fetchflag)
+ (setq remove (nreverse remove))
+ (imap-message-flags-add
+ (imap-range-to-message-set (gnus-compress-sequence remove))
+ fetchflag nil buf))
+ (if dontexpunge
+ (imap-mailbox-unselect buf)
+ (imap-mailbox-close nil buf)))))
+ (imap-close buf))
+ (imap-close buf)
+ ;; We nix out the password in case the error
+ ;; was because of a wrong password being given.
+ (setq mail-source-password-cache
+ (delq (assoc from mail-source-password-cache)
+ mail-source-password-cache))
+ (error "IMAP error: %s" (imap-error-text buf)))
+ (kill-buffer buf)
+ (mail-source-run-script
+ postscript
+ `((?p . ,password) (?t . ,crash-box)
+ (?s . ,server) (?P . ,port) (?u . ,user)))
+ found))))
(provide 'mail-source)
--
2.34.1
[-- Attachment #3: Type: text/plain, Size: 33 bytes --]
Best regards,
--
Manuel Giraud
^ permalink raw reply related [flat|nested] 9+ messages in thread
end of thread, other threads:[~2022-02-01 16:26 UTC | newest]
Thread overview: 9+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-01-24 16:58 async Gnus Manuel Giraud
2022-01-25 17:29 ` Eric Abrahamsen
2022-01-26 10:05 ` Manuel Giraud
2022-01-26 13:10 ` Eli Zaretskii
2022-01-26 14:58 ` Manuel Giraud
2022-01-26 15:32 ` Thomas Fitzsimmons
2022-01-26 16:36 ` Manuel Giraud
2022-01-26 17:53 ` Eric Abrahamsen
2022-02-01 16:26 ` Manuel Giraud
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).