From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Manuel Giraud Newsgroups: gmane.emacs.devel Subject: Re: async Gnus Date: Tue, 01 Feb 2022 17:26:01 +0100 Message-ID: <87sft21rl2.fsf@elite.giraud> References: <87a6flqddp.fsf@elite.giraud> <87fspbzpu5.fsf@ericabrahamsen.net> <87wnimn760.fsf@elite.giraud> <83ee4uhccg.fsf@gnu.org> <871r0umtm1.fsf@elite.giraud> <87k0emlaiv.fsf@elite.giraud> <87pmoexu2l.fsf@ericabrahamsen.net> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="36221"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/29.0.50 (berkeley-unix) Cc: emacs-devel@gnu.org To: Eric Abrahamsen Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Tue Feb 01 19:33:05 2022 Return-path: Envelope-to: ged-emacs-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1nExxg-0009Ab-Iv for ged-emacs-devel@m.gmane-mx.org; Tue, 01 Feb 2022 19:33:04 +0100 Original-Received: from localhost ([::1]:42780 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1nExxe-0004aT-M4 for ged-emacs-devel@m.gmane-mx.org; Tue, 01 Feb 2022 13:33:02 -0500 Original-Received: from eggs.gnu.org ([209.51.188.92]:42298) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1nEvze-0003A8-HQ for emacs-devel@gnu.org; Tue, 01 Feb 2022 11:26:58 -0500 Original-Received: from ledu-giraud.fr ([51.159.28.247]:18342) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1nEvzb-0007Vg-56 for emacs-devel@gnu.org; Tue, 01 Feb 2022 11:26:58 -0500 DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; s=rsa; bh=Z1sCRyy4j+3vbU2h WGuhFd4MJ16VzsUStbCLaDx1c+U=; h=in-reply-to:date:references:subject: cc:to:from; d=ledu-giraud.fr; b=HR9V1ncz8F0NIJ/Jf/pfBLoDBv5CwM1GjcdWt5 RHQu84BORgHk4OqBdGwZRdVrAuPDgl/oQdJqb8IYpAy8N2ehbbPfqdq4STFRbhVD/Hg9pZ B2GGd5ISRBrwwnFcqgGXMQHf4+BZJbMGzKg5xL6JfLEwgYsEhfXPmrMBFicKZe9Vj1nium tlqR2HY0up2aANSnaXtp7lq6hsR2J4lE7dGdteots70xv7XGO5zW/8SySuYMprk0bHpu6h uzZM6XLJuuoqDondEZOL/knTeqMSX6jqLxgx61q/LQPTnWG7GFBJIR63Yy/5v+MAXOYGWs JRnpFgsgWlcyX0gOfjEQ1Shg== Original-Received: from elite.giraud ( [10.1.1.1]) by ledu-giraud.fr (OpenSMTPD) with ESMTPSA id 087f0af6 (TLSv1.3:AEAD-AES256-GCM-SHA384:256:NO); Tue, 1 Feb 2022 17:26:02 +0100 (CET) In-Reply-To: <87pmoexu2l.fsf@ericabrahamsen.net> (Eric Abrahamsen's message of "Wed, 26 Jan 2022 09:53:06 -0800") Received-SPF: pass client-ip=51.159.28.247; envelope-from=manuel@ledu-giraud.fr; helo=ledu-giraud.fr X-Spam_score_int: -20 X-Spam_score: -2.1 X-Spam_bar: -- X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, SPF_HELO_PASS=-0.001, SPF_PASS=-0.001, T_SCC_BODY_TEXT_LINE=-0.01 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Original-Sender: "Emacs-devel" Xref: news.gmane.io gmane.emacs.devel:285733 Archived-At: --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable 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=E2=80=A6 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. --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-uniquify-mail-source-crash-box-on-each-different-mai.patch >From 734b13491965ae85907568a3d392e4fdb74a675a Mon Sep 17 00:00:00 2001 From: Manuel Giraud 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 --=-=-= Content-Type: text/plain Best regards, -- Manuel Giraud --=-=-=--