diff options
Diffstat (limited to 'lisp/gnus/gnus-sum.el')
| -rw-r--r-- | lisp/gnus/gnus-sum.el | 425 |
1 files changed, 214 insertions, 211 deletions
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 2d679dab246..840e7d5a000 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -1310,7 +1310,6 @@ the normal Gnus MIME machinery." (defvar gnus-article-decoded-p nil) (defvar gnus-article-charset nil) (defvar gnus-article-ignored-charsets nil) -(defvar gnus-article-original-subject nil) (defvar gnus-scores-exclude-files nil) (defvar gnus-page-broken nil) @@ -1336,7 +1335,6 @@ the normal Gnus MIME machinery." (defvar gnus-current-copy-group nil) (defvar gnus-current-crosspost-group nil) (defvar gnus-newsgroup-display nil) -(defvar gnus-newsgroup-original-name nil) (defvar gnus-newsgroup-dependencies nil) (defvar gnus-newsgroup-adaptive nil) @@ -1363,6 +1361,16 @@ the normal Gnus MIME machinery." (?c (or (mail-header-chars gnus-tmp-header) 0) ?d) (?k (gnus-summary-line-message-size gnus-tmp-header) ?s) (?L gnus-tmp-lines ?s) + (?Z (or ,(macroexpand-all + '(nnir-article-rsv (mail-header-number gnus-tmp-header))) + 0) ?d) + (?G (or ,(macroexpand-all + '(nnir-article-group (mail-header-number gnus-tmp-header))) + "") ?s) + (?g (or ,(macroexpand-all + '(gnus-group-short-name + (nnir-article-group (mail-header-number gnus-tmp-header)))) + "") ?s) (?O gnus-tmp-downloaded ?c) (?I gnus-tmp-indentation ?s) (?T (if (= gnus-tmp-level 0) "" (make-string (frame-width) ? )) ?s) @@ -1583,6 +1591,8 @@ This list will always be a subset of gnus-newsgroup-undownloaded.") gnus-newsgroup-prepared gnus-summary-highlight-line-function gnus-current-article gnus-current-headers gnus-have-all-headers gnus-last-article gnus-article-internal-prepare-hook + (gnus-summary-article-delete-hook . global) + (gnus-summary-article-move-hook . global) gnus-newsgroup-dependencies gnus-newsgroup-selected-overlay gnus-newsgroup-scored gnus-newsgroup-kill-headers gnus-thread-expunge-below @@ -9731,210 +9741,203 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." ;; Set any marks that may have changed in the summary buffer. (when gnus-preserve-marks (gnus-summary-push-marks-to-backend article)) - (let ((gnus-newsgroup-original-name gnus-newsgroup-name) - (gnus-article-original-subject - (mail-header-subject - (gnus-data-header (assoc article (gnus-data-list nil)))))) - (setq - art-group - (cond - ;; Move the article. - ((eq action 'move) - ;; Remove this article from future suppression. - (gnus-dup-unsuppress-article article) - (let* ((from-method (gnus-find-method-for-group - gnus-newsgroup-name)) - (to-method (or select-method - (gnus-find-method-for-group to-newsgroup))) - (move-is-internal (gnus-server-equal from-method to-method))) - (gnus-request-move-article - article ; Article to move - gnus-newsgroup-name ; From newsgroup - (nth 1 (gnus-find-method-for-group - gnus-newsgroup-name)) ; Server - (list 'gnus-request-accept-article - to-newsgroup (list 'quote select-method) - (not articles) t) ; Accept form - (not articles) ; Only save nov last time - (and move-is-internal - to-newsgroup ; Not respooling + (setq + art-group + (cond + ;; Move the article. + ((eq action 'move) + ;; Remove this article from future suppression. + (gnus-dup-unsuppress-article article) + (let* ((from-method (gnus-find-method-for-group + gnus-newsgroup-name)) + (to-method (or select-method + (gnus-find-method-for-group to-newsgroup))) + (move-is-internal (gnus-server-equal from-method to-method))) + (gnus-request-move-article + article ; Article to move + gnus-newsgroup-name ; From newsgroup + (nth 1 (gnus-find-method-for-group + gnus-newsgroup-name)) ; Server + (list 'gnus-request-accept-article + to-newsgroup (list 'quote select-method) + (not articles) t) ; Accept form + (not articles) ; Only save nov last time + (and move-is-internal + to-newsgroup ; Not respooling ; Is this move internal? - (gnus-group-real-name to-newsgroup))))) - ;; Copy the article. - ((eq action 'copy) + (gnus-group-real-name to-newsgroup))))) + ;; Copy the article. + ((eq action 'copy) + (with-current-buffer copy-buf + (when (gnus-request-article-this-buffer article + gnus-newsgroup-name) + (save-restriction + (nnheader-narrow-to-headers) + (dolist (hdr gnus-copy-article-ignored-headers) + (message-remove-header hdr t))) + (gnus-request-accept-article + to-newsgroup select-method (not articles) t)))) + ;; Crosspost the article. + ((eq action 'crosspost) + (let ((xref (message-tokenize-header + (mail-header-xref (gnus-summary-article-header + article)) + " "))) + (setq new-xref (concat (gnus-group-real-name gnus-newsgroup-name) + ":" (number-to-string article))) + (unless xref + (setq xref (list (system-name)))) + (setq new-xref + (concat + (mapconcat 'identity + (delete "Xref:" (delete new-xref xref)) + " ") + " " new-xref)) (with-current-buffer copy-buf - (when (gnus-request-article-this-buffer article - gnus-newsgroup-name) - (save-restriction - (nnheader-narrow-to-headers) - (dolist (hdr gnus-copy-article-ignored-headers) - (message-remove-header hdr t))) - (gnus-request-accept-article - to-newsgroup select-method (not articles) t)))) - ;; Crosspost the article. - ((eq action 'crosspost) - (let ((xref (message-tokenize-header - (mail-header-xref (gnus-summary-article-header - article)) - " "))) - (setq new-xref (concat (gnus-group-real-name gnus-newsgroup-name) - ":" (number-to-string article))) - (unless xref - (setq xref (list (system-name)))) - (setq new-xref - (concat - (mapconcat 'identity - (delete "Xref:" (delete new-xref xref)) - " ") - " " new-xref)) - (with-current-buffer copy-buf - ;; First put the article in the destination group. - (gnus-request-article-this-buffer article gnus-newsgroup-name) - (when (consp (setq art-group - (gnus-request-accept-article - to-newsgroup select-method (not articles) - t))) - (setq new-xref (concat new-xref " " (car art-group) - ":" - (number-to-string (cdr art-group)))) - ;; Now we have the new Xrefs header, so we insert - ;; it and replace the new article. - (nnheader-replace-header "Xref" new-xref) - (gnus-request-replace-article - (cdr art-group) to-newsgroup (current-buffer) t) - art-group)))))) - (cond - ((not art-group) - (gnus-message 1 "Couldn't %s article %s: %s" - (cadr (assq action names)) article - (nnheader-get-report (car to-method)))) - ((eq art-group 'junk) - (when (eq action 'move) - (gnus-summary-mark-article article gnus-canceled-mark) - (gnus-message 4 "Deleted article %s" article) - ;; run the delete hook - (run-hook-with-args 'gnus-summary-article-delete-hook - action - (gnus-data-header - (assoc article (gnus-data-list nil))) - gnus-newsgroup-original-name nil - select-method))) - (t - (let* ((pto-group (gnus-group-prefixed-name - (car art-group) to-method)) - (info (gnus-get-info pto-group)) - (to-group (gnus-info-group info)) - to-marks) - ;; Update the group that has been moved to. - (when (and info - (memq action '(move copy))) - (unless (member to-group to-groups) - (push to-group to-groups)) - - (unless (memq article gnus-newsgroup-unreads) - (push 'read to-marks) - (gnus-info-set-read - info (gnus-add-to-range (gnus-info-read info) - (list (cdr art-group))))) - - ;; See whether the article is to be put in the cache. - (let* ((expirable (gnus-group-auto-expirable-p to-group)) - (marks (if expirable - gnus-article-mark-lists - (delete '(expirable . expire) - (copy-sequence - gnus-article-mark-lists)))) - (to-article (cdr art-group))) - - ;; Enter the article into the cache in the new group, - ;; if that is required. - (when gnus-use-cache - (gnus-cache-possibly-enter-article - to-group to-article - (memq article gnus-newsgroup-marked) - (memq article gnus-newsgroup-dormant) - (memq article gnus-newsgroup-unreads))) - - (when gnus-preserve-marks - ;; Copy any marks over to the new group. - (when (and (equal to-group gnus-newsgroup-name) - (not (memq article gnus-newsgroup-unreads))) - ;; Mark this article as read in this group. - (push (cons to-article gnus-read-mark) - gnus-newsgroup-reads) - ;; Increase the active status of this group. - (setcdr (gnus-active to-group) to-article) - (setcdr gnus-newsgroup-active to-article)) - - (while marks - (when (eq (gnus-article-mark-to-type (cdar marks)) 'list) - (when (memq article (symbol-value - (intern (format "gnus-newsgroup-%s" - (caar marks))))) - (push (cdar marks) to-marks) - ;; If the other group is the same as this group, - ;; then we have to add the mark to the list. - (when (equal to-group gnus-newsgroup-name) - (set (intern (format "gnus-newsgroup-%s" - (caar marks))) - (cons to-article - (symbol-value - (intern (format "gnus-newsgroup-%s" - (caar marks))))))) - ;; Copy the marks to other group. - (gnus-add-marked-articles - to-group (cdar marks) (list to-article) info))) - (setq marks (cdr marks))) - - (when (and expirable - gnus-mark-copied-or-moved-articles-as-expirable - (not (memq 'expire to-marks))) - ;; Mark this article as expirable. - (push 'expire to-marks) - (when (equal to-group gnus-newsgroup-name) - (push to-article gnus-newsgroup-expirable)) - ;; Copy the expirable mark to other group. - (gnus-add-marked-articles - to-group 'expire (list to-article) info)) - - (when to-marks - (gnus-request-set-mark - to-group (list (list (list to-article) 'add to-marks))))) - - (gnus-dribble-enter - (concat "(gnus-group-set-info '" - (gnus-prin1-to-string (gnus-get-info to-group)) - ")")))) - - ;; Update the Xref header in this article to point to - ;; the new crossposted article we have just created. - (when (eq action 'crosspost) - (with-current-buffer copy-buf - (gnus-request-article-this-buffer article gnus-newsgroup-name) - (nnheader-replace-header "Xref" new-xref) - (gnus-request-replace-article - article gnus-newsgroup-name (current-buffer) t))) - - ;; run the move/copy/crosspost/respool hook - (let ((header (gnus-data-header - (assoc article (gnus-data-list nil))))) - (mail-header-set-subject header gnus-article-original-subject) - (run-hook-with-args 'gnus-summary-article-move-hook - action - (gnus-data-header - (assoc article (gnus-data-list nil))) - gnus-newsgroup-original-name - to-newsgroup - select-method))) - - ;;;!!!Why is this necessary? - (set-buffer gnus-summary-buffer) - - (when (eq action 'move) - (save-excursion - (gnus-summary-goto-subject article) - (gnus-summary-mark-article article gnus-canceled-mark))))) - (push article articles-to-update-marks))) + ;; First put the article in the destination group. + (gnus-request-article-this-buffer article gnus-newsgroup-name) + (when (consp (setq art-group + (gnus-request-accept-article + to-newsgroup select-method (not articles) + t))) + (setq new-xref (concat new-xref " " (car art-group) + ":" + (number-to-string (cdr art-group)))) + ;; Now we have the new Xrefs header, so we insert + ;; it and replace the new article. + (nnheader-replace-header "Xref" new-xref) + (gnus-request-replace-article + (cdr art-group) to-newsgroup (current-buffer) t) + art-group)))))) + (cond + ((not art-group) + (gnus-message 1 "Couldn't %s article %s: %s" + (cadr (assq action names)) article + (nnheader-get-report (car to-method)))) + ((eq art-group 'junk) + (when (eq action 'move) + (gnus-summary-mark-article article gnus-canceled-mark) + (gnus-message 4 "Deleted article %s" article) + ;; run the delete hook + (run-hook-with-args 'gnus-summary-article-delete-hook + action + (gnus-data-header + (assoc article (gnus-data-list nil))) + gnus-newsgroup-name nil + select-method))) + (t + (let* ((pto-group (gnus-group-prefixed-name + (car art-group) to-method)) + (info (gnus-get-info pto-group)) + (to-group (gnus-info-group info)) + to-marks) + ;; Update the group that has been moved to. + (when (and info + (memq action '(move copy))) + (unless (member to-group to-groups) + (push to-group to-groups)) + + (unless (memq article gnus-newsgroup-unreads) + (push 'read to-marks) + (gnus-info-set-read + info (gnus-add-to-range (gnus-info-read info) + (list (cdr art-group))))) + + ;; See whether the article is to be put in the cache. + (let* ((expirable (gnus-group-auto-expirable-p to-group)) + (marks (if expirable + gnus-article-mark-lists + (delete '(expirable . expire) + (copy-sequence + gnus-article-mark-lists)))) + (to-article (cdr art-group))) + + ;; Enter the article into the cache in the new group, + ;; if that is required. + (when gnus-use-cache + (gnus-cache-possibly-enter-article + to-group to-article + (memq article gnus-newsgroup-marked) + (memq article gnus-newsgroup-dormant) + (memq article gnus-newsgroup-unreads))) + + (when gnus-preserve-marks + ;; Copy any marks over to the new group. + (when (and (equal to-group gnus-newsgroup-name) + (not (memq article gnus-newsgroup-unreads))) + ;; Mark this article as read in this group. + (push (cons to-article gnus-read-mark) + gnus-newsgroup-reads) + ;; Increase the active status of this group. + (setcdr (gnus-active to-group) to-article) + (setcdr gnus-newsgroup-active to-article)) + + (while marks + (when (eq (gnus-article-mark-to-type (cdar marks)) 'list) + (when (memq article (symbol-value + (intern (format "gnus-newsgroup-%s" + (caar marks))))) + (push (cdar marks) to-marks) + ;; If the other group is the same as this group, + ;; then we have to add the mark to the list. + (when (equal to-group gnus-newsgroup-name) + (set (intern (format "gnus-newsgroup-%s" + (caar marks))) + (cons to-article + (symbol-value + (intern (format "gnus-newsgroup-%s" + (caar marks))))))) + ;; Copy the marks to other group. + (gnus-add-marked-articles + to-group (cdar marks) (list to-article) info))) + (setq marks (cdr marks))) + + (when (and expirable + gnus-mark-copied-or-moved-articles-as-expirable + (not (memq 'expire to-marks))) + ;; Mark this article as expirable. + (push 'expire to-marks) + (when (equal to-group gnus-newsgroup-name) + (push to-article gnus-newsgroup-expirable)) + ;; Copy the expirable mark to other group. + (gnus-add-marked-articles + to-group 'expire (list to-article) info)) + + (when to-marks + (gnus-request-set-mark + to-group (list (list (list to-article) 'add to-marks))))) + + (gnus-dribble-enter + (concat "(gnus-group-set-info '" + (gnus-prin1-to-string (gnus-get-info to-group)) + ")")))) + + ;; Update the Xref header in this article to point to + ;; the new crossposted article we have just created. + (when (eq action 'crosspost) + (with-current-buffer copy-buf + (gnus-request-article-this-buffer article gnus-newsgroup-name) + (nnheader-replace-header "Xref" new-xref) + (gnus-request-replace-article + article gnus-newsgroup-name (current-buffer) t))) + + ;; run the move/copy/crosspost/respool hook + (run-hook-with-args 'gnus-summary-article-move-hook + action + (gnus-data-header + (assoc article (gnus-data-list nil))) + gnus-newsgroup-name + to-newsgroup + select-method)) + + ;;;!!!Why is this necessary? + (set-buffer gnus-summary-buffer) + + (when (eq action 'move) + (save-excursion + (gnus-summary-goto-subject article) + (gnus-summary-mark-article article gnus-canceled-mark))))) + (push article articles-to-update-marks)) (save-excursion (apply 'gnus-summary-remove-process-mark articles-to-update-marks)) @@ -10213,13 +10216,13 @@ confirmation before the articles are deleted." ;; The backend might not have been able to delete the article ;; after all. (unless (memq (car articles) not-deleted) - (gnus-summary-mark-article (car articles) gnus-canceled-mark)) - (let* ((article (car articles)) - (ghead (gnus-data-header - (assoc article (gnus-data-list nil))))) - (run-hook-with-args 'gnus-summary-article-delete-hook - 'delete ghead gnus-newsgroup-name nil - nil)) + (gnus-summary-mark-article (car articles) gnus-canceled-mark) + (let* ((article (car articles)) + (ghead (gnus-data-header + (assoc article (gnus-data-list nil))))) + (run-hook-with-args 'gnus-summary-article-delete-hook + 'delete ghead gnus-newsgroup-name nil + nil))) (setq articles (cdr articles)))) (when not-deleted (gnus-message 4 "Couldn't delete articles %s" not-deleted))) |