From 3ef54c64fa8e7236458228db09fe7192350cbeb6 Mon Sep 17 00:00:00 2001 From: Andrew G Cohen Date: Fri, 14 Apr 2023 08:42:29 +0800 Subject: [PATCH] Fix and cleanup nnselect-push-info * lisp/gnus/nnselect.el (nnselect-push-info): Don't update backend marks when quit-config is not nil since gnus-update-marks has already been called. Move checking for unread articles outside the gnus-atomic block so it may be interrupted. Replace let* with let. Cleanup code. --- lisp/gnus/nnselect.el | 217 +++++++++++++++++++++--------------------- 1 file changed, 107 insertions(+), 110 deletions(-) diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index 57a833de9bf..4eaaffe34a5 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -885,13 +885,14 @@ article came from is also searched." -(defun nnselect-push-info (_group) +(defun nnselect-push-info (group) "Copy mark-lists from GROUP to the originating groups." (let ((select-unreads (numbers-by-group gnus-newsgroup-unreads)) (select-reads (numbers-by-group (gnus-sorted-difference gnus-newsgroup-articles gnus-newsgroup-unreads))) (select-unseen (numbers-by-group gnus-newsgroup-unseen)) + (quit-config (gnus-group-quit-config group)) (gnus-newsgroup-active nil) mark-list) ;; collect the set of marked article lists categorized by ;; originating groups @@ -903,124 +904,120 @@ article came from is also searched." (unless (eq 'tuple mark-type) (setq type-list (range-list-intersection gnus-newsgroup-articles type-list))) - (push (cons - type - (numbers-by-group type-list mark-type)) + (push (cons type (numbers-by-group type-list mark-type)) mark-list)))) ;; now work on each originating group one at a time (pcase-dolist (`(,artgroup . ,artlist) - (numbers-by-group gnus-newsgroup-articles)) + (numbers-by-group gnus-newsgroup-articles)) (setq artlist (sort artlist #'<)) - (let* ((group-info (gnus-get-info artgroup)) - (old-unread (gnus-list-of-unread-articles artgroup)) - newmarked delta-marks) - (when group-info - ;; iterate over mark lists for this group - (pcase-dolist (`(,_mark . ,type) gnus-article-mark-lists) - (let ((list (cdr (assoc artgroup (alist-get type mark-list)))) - (mark-type (gnus-article-mark-to-type type))) - - ;; When the backend can store marks we collect any - ;; changes. Unlike a normal group the mark lists only - ;; include marks for articles we retrieved. - (when (and (gnus-check-backend-function - 'request-set-mark gnus-newsgroup-name) - (not (gnus-article-unpropagatable-p type))) - (let* ((old (range-list-intersection - artlist - (alist-get type (gnus-info-marks group-info)))) - (del (range-remove (copy-tree old) list)) - (add (range-remove (copy-tree list) old))) - (when add (push (list add 'add (list type)) delta-marks)) - (when del - ;; Don't delete marks from outside the active range. - ;; This shouldn't happen, but is a sanity check. - (setq del (range-intersection - (gnus-active artgroup) del)) - (push (list del 'del (list type)) delta-marks)))) - - ;; Marked sets are of mark-type 'tuple, 'list, or - ;; 'range. We merge the lists with what is already in - ;; the original info to get full list of new marks. We - ;; do this by removing all the articles we retrieved - ;; from the full list, and then add back in the newly - ;; marked ones. - (cond - ((eq mark-type 'tuple) - ;; Get rid of the entries that have the default - ;; score. - (when (and list (eq type 'score) gnus-save-score) - (let* ((arts list) - (prev (cons nil list)) - (all prev)) - (while arts - (if (or (not (consp (car arts))) - (= (cdar arts) gnus-summary-default-score)) - (setcdr prev (cdr arts)) - (setq prev arts)) - (setq arts (cdr arts))) - (setq list (cdr all)))) - ;; now merge with the original list and sort just to - ;; make sure - (setq - list (sort + (let ((group-info (gnus-get-info artgroup)) + (old-unread (gnus-list-of-unread-articles artgroup)) + (rsm (gnus-check-backend-function 'request-set-mark artgroup)) + newmarked delta-marks) + (when group-info + ;; iterate over mark lists for this group + (pcase-dolist (`(,_mark . ,type) gnus-article-mark-lists) + (let ((list (cdr (assoc artgroup (alist-get type mark-list)))) + (mark-type (gnus-article-mark-to-type type)) + (group-marks (alist-get type (gnus-info-marks group-info)))) + + ;; When the backend can store marks we collect any + ;; changes. Unlike a normal group the mark lists only + ;; include marks for articles we retrieved. If there is + ;; no quit-config then gnus-update-marks has already + ;; been called to handle this. + (when (and quit-config rsm + (not (gnus-article-unpropagatable-p type))) + (let* ((old (range-list-intersection + artlist group-marks)) + (del (range-remove (copy-tree old) list)) + (add (range-remove (copy-tree list) old))) + (when add (push (list add 'add (list type)) delta-marks)) + (when del + ;; Don't delete marks from outside the active range. + ;; This shouldn't happen, but is a sanity check. + (setq del (range-intersection (gnus-active artgroup) del)) + (push (list del 'del (list type)) delta-marks)))) + + ;; Marked sets are of mark-type 'tuple, 'list, or + ;; 'range. We merge the lists with what is already in + ;; the original info to get full list of new marks. We + ;; do this by removing all the articles we retrieved + ;; from the full list, and then add back in the newly + ;; marked ones. + (cond + ((eq mark-type 'tuple) + ;; Get rid of the entries that have the default + ;; score. + (when (and list (eq type 'score) gnus-save-score) + (let* ((arts list) + (prev (cons nil list)) + (all prev)) + (while arts + (if (or (not (consp (car arts))) + (= (cdar arts) gnus-summary-default-score)) + (setcdr prev (cdr arts)) + (setq prev arts)) + (setq arts (cdr arts))) + (setq list (cdr all)))) + ;; now merge with the original list and sort just to + ;; make sure + (setq list + (sort (map-merge - 'alist list + 'alist list (delq nil (mapcar (lambda (x) (unless (memq (car x) artlist) x)) - (alist-get type (gnus-info-marks group-info))))) + group-marks))) 'car-less-than-car))) - (t - (setq list - (range-compress-list - (gnus-sorted-union - (gnus-sorted-difference - (gnus-uncompress-sequence - (alist-get type (gnus-info-marks group-info))) - artlist) - (sort list #'<))))) - - ;; When exiting the group, everything that's previously been - ;; unseen is now seen. - (when (eq type 'seen) - (setq list (range-concat - list (cdr (assoc artgroup select-unseen)))))) - - (when (or list (eq type 'unexist)) - (push (cons type list) newmarked)))) ;; end of mark-type loop - - (when delta-marks - (unless (gnus-check-group artgroup) - (error "Can't open server for %s" artgroup)) - (gnus-request-set-mark artgroup delta-marks)) - - (gnus-atomic-progn - (gnus-info-set-marks group-info newmarked) - ;; Cut off the end of the info if there's nothing else there. - (let ((i 5)) - (while (and (> i 2) - (not (nth i group-info))) - (when (nthcdr (cl-decf i) group-info) - (setcdr (nthcdr i group-info) nil)))) - - ;; update read and unread - (gnus-update-read-articles - artgroup - (range-uncompress - (range-add-list - (range-remove - old-unread - (cdr (assoc artgroup select-reads))) - (sort (cdr (assoc artgroup select-unreads)) #'<)))) - (gnus-get-unread-articles-in-group - group-info (gnus-active artgroup) t)) - (gnus-group-update-group - artgroup t - (equal group-info - (setq group-info (copy-sequence (gnus-get-info artgroup)) - group-info - (delq (gnus-info-params group-info) group-info))))))))) + (t + (setq list + (range-compress-list + (gnus-sorted-union + (gnus-sorted-difference + (gnus-uncompress-sequence group-marks) + artlist) + (sort list #'<)))) + + ;; When exiting the group, everything that's previously been + ;; unseen is now seen. + (when (eq type 'seen) + (setq list (range-concat + list (cdr (assoc artgroup select-unseen))))))) + + (when (or list (eq type 'unexist)) + (push (cons type list) newmarked)))) ;; end of mark-type loop + (when delta-marks + (unless (gnus-check-group artgroup) + (error "Can't open server for %s" artgroup)) + (gnus-request-set-mark artgroup delta-marks)) + (gnus-atomic-progn + (gnus-info-set-marks group-info newmarked) + ;; Cut off the end of the info if there's nothing else there. + (let ((i 5)) + (while (and (> i 2) + (not (nth i group-info))) + (when (nthcdr (cl-decf i) group-info) + (setcdr (nthcdr i group-info) nil)))) + + ;; update read and unread + (gnus-update-read-articles + artgroup + (range-uncompress + (range-add-list + (range-remove + old-unread + (cdr (assoc artgroup select-reads))) + (sort (cdr (assoc artgroup select-unreads)) #'<))))) + (gnus-get-unread-articles-in-group + group-info (gnus-active artgroup) t) + (gnus-group-update-group + artgroup t + (equal group-info + (setq group-info (copy-sequence (gnus-get-info artgroup)) + group-info + (delq (gnus-info-params group-info) group-info))))))))) (declare-function gnus-registry-get-id-key "gnus-registry" (id key)) -- 2.39.2