X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-sum.el;h=bfc78a3998bf5ba39905945ce4e6a52030d644f5;hb=e42093da43ac9af894c2c28f5b62c7256252769e;hp=bce7a0c39960370cbf66c6fcd1f637ba52d21956;hpb=35954395de6fe886702bd3f5a8ae48c28c6a739c;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el index bce7a0c..bfc78a3 100644 --- a/lisp/gnus-sum.el +++ b/lisp/gnus-sum.el @@ -3,6 +3,7 @@ ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko +;; Katsumi Yamaoka ;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -37,12 +38,16 @@ (require 'gnus-util) (require 'mime-view) -;; Avoid byte-compile warnings. (eval-when-compile + (require 'mime-play) + ;; Avoid byte-compile warnings. (defvar gnus-article-decoded-p) (defvar gnus-decode-encoded-word-function) ) +(eval-and-compile + (autoload 'gnus-cache-articles-in-group "gnus-cache")) + (autoload 'gnus-summary-limit-include-cached "gnus-cache" nil t) (autoload 'gnus-set-summary-default-charset "gnus-i18n" nil t) @@ -622,7 +627,7 @@ See `gnus-thread-score-function' for en explanation of what a \"thread score\" is. This variable is local to the summary buffers." - :group 'gnus-treading + :group 'gnus-threading :group 'gnus-score-default :type '(choice (const :tag "off" nil) integer)) @@ -815,12 +820,23 @@ which it may alter in any way.") ("^cn\\>\\|\\" cn-gb-2312) ("^fj\\>\\|^japan\\>" iso-2022-jp-2) ("^relcom\\>" koi8-r) + ("^\\(cz\\|hun\\|pl\\|sk\\|hr\\)\\>" iso-8859-2) + ("^israel\\>" iso-8859-1) + ("^han\\>" euc-kr) + ("^\\(comp\\|rec\\|alt\\|sci\\|soc\\|news\\|gnu\\|bofh\\)\\>" iso-8859-1) (".*" iso-8859-1)) - "Alist of regexps (to match group names) and default charsets to be used." + "Alist of regexps (to match group names) and default charsets to be used when reading." :type '(repeat (list (regexp :tag "Group") (symbol :tag "Charset"))) :group 'gnus-charset) +(defcustom gnus-newsgroup-ignored-charsets '(unknown-8bit) + "List of charsets that should be ignored. +When these charsets are used in the \"charset\" parameter, the +default charset will be used instead." + :type '(repeat symbol) + :group 'gnus-charset) + ;;; Internal variables (defvar gnus-scores-exclude-files nil) @@ -1030,7 +1046,8 @@ variable (string, integer, character, etc).") gnus-newsgroup-dependencies gnus-newsgroup-selected-overlay gnus-newsgroup-scored gnus-newsgroup-kill-headers gnus-thread-expunge-below - gnus-score-alist gnus-current-score-file gnus-summary-expunge-below + gnus-score-alist gnus-current-score-file + (gnus-summary-expunge-below . global) (gnus-summary-mark-below . global) gnus-newsgroup-active gnus-scores-exclude-files gnus-newsgroup-history gnus-newsgroup-ancient @@ -1237,6 +1254,7 @@ increase the score of each group you read." "\C-c\M-\C-s" gnus-summary-limit-include-expunged "\C-c\C-s\C-n" gnus-summary-sort-by-number "\C-c\C-s\C-l" gnus-summary-sort-by-lines + "\C-c\C-s\C-c" gnus-summary-sort-by-chars "\C-c\C-s\C-a" gnus-summary-sort-by-author "\C-c\C-s\C-s" gnus-summary-sort-by-subject "\C-c\C-s\C-d" gnus-summary-sort-by-date @@ -1268,7 +1286,7 @@ increase the score of each group you read." "a" gnus-summary-post-news "x" gnus-summary-limit-to-unread "s" gnus-summary-isearch-article - "t" gnus-article-hide-headers + "t" gnus-article-toggle-headers "g" gnus-summary-show-article "l" gnus-summary-goto-last-article "v" gnus-summary-preview-mime-message @@ -1328,6 +1346,7 @@ increase the score of each group you read." "a" gnus-summary-limit-to-author "u" gnus-summary-limit-to-unread "m" gnus-summary-limit-to-marks + "M" gnus-summary-limit-exclude-marks "v" gnus-summary-limit-to-score "*" gnus-summary-limit-include-cached "D" gnus-summary-limit-include-dormant @@ -1404,6 +1423,7 @@ increase the score of each group you read." "e" gnus-summary-end-of-article "^" gnus-summary-refer-parent-article "r" gnus-summary-refer-parent-article + "D" gnus-summary-enter-digest-group "R" gnus-summary-refer-references "T" gnus-summary-refer-thread "g" gnus-summary-show-article @@ -1422,15 +1442,16 @@ increase the score of each group you read." "f" gnus-article-display-x-face "l" gnus-summary-stop-page-breaking "r" gnus-summary-caesar-message - "t" gnus-article-hide-headers + "t" gnus-article-toggle-headers "v" gnus-summary-verbose-headers "m" gnus-summary-toggle-mime "h" gnus-article-treat-html + "H" gnus-article-strip-headers-in-body "d" gnus-article-treat-dumbquotes) (gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map) "a" gnus-article-hide - "h" gnus-article-hide-headers + "h" gnus-article-toggle-headers "b" gnus-article-hide-boring-headers "s" gnus-article-hide-signature "c" gnus-article-hide-citation @@ -1505,6 +1526,7 @@ increase the score of each group you read." "o" gnus-article-save-part "c" gnus-article-copy-part "e" gnus-article-externalize-part + "i" gnus-article-inline-part "|" gnus-article-pipe-part) ) @@ -1546,7 +1568,7 @@ increase the score of each group you read." (let ((innards '(("Hide" ["All" gnus-article-hide t] - ["Headers" gnus-article-hide-headers t] + ["Headers" gnus-article-toggle-headers t] ["Signature" gnus-article-hide-signature t] ["Citation" gnus-article-hide-citation t] ["PGP" gnus-article-hide-pgp t] @@ -1732,6 +1754,7 @@ increase the score of each group you read." ["Hide childless dormant" gnus-summary-limit-exclude-childless-dormant t] ;;["Hide thread" gnus-summary-limit-exclude-thread t] + ["Hide marked" gnus-summary-limit-exclude-marks t] ["Show expunged" gnus-summary-show-all-expunged t]) ("Process Mark" ["Set mark" gnus-summary-mark-as-processable t] @@ -1778,7 +1801,8 @@ increase the score of each group you read." ["Sort by subject" gnus-summary-sort-by-subject t] ["Sort by date" gnus-summary-sort-by-date t] ["Sort by score" gnus-summary-sort-by-score t] - ["Sort by lines" gnus-summary-sort-by-lines t]) + ["Sort by lines" gnus-summary-sort-by-lines t] + ["Sort by characters" gnus-summary-sort-by-chars t]) ("Help" ["Fetch group FAQ" gnus-summary-fetch-faq t] ["Describe group" gnus-summary-describe-group t] @@ -3140,12 +3164,11 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." (nnheader-nov-field) ; subject (nnheader-nov-field) ; from (nnheader-nov-field) ; date - (or (nnheader-nov-field) ; id - (nnheader-generate-fake-message-id)) + (nnheader-nov-read-message-id) ; id (nnheader-nov-field) ; refs (nnheader-nov-read-integer) ; chars (nnheader-nov-read-integer) ; lines - (unless (eq (char-after) ?\n) + (unless (eobp) (nnheader-nov-field)) ; misc (nnheader-nov-parse-extra))) ; extra @@ -3530,14 +3553,24 @@ If LINE, insert the rebuilt thread starting on line LINE." (gnus-article-sort-by-lines (gnus-thread-header h1) (gnus-thread-header h2))) +(defsubst gnus-article-sort-by-chars (h1 h2) + "Sort articles by octet length." + (< (mail-header-chars h1) + (mail-header-chars h2))) + +(defun gnus-thread-sort-by-chars (h1 h2) + "Sort threads by root article octet length." + (gnus-article-sort-by-chars + (gnus-thread-header h1) (gnus-thread-header h2))) + (defsubst gnus-article-sort-by-author (h1 h2) "Sort articles by root author." (string-lessp - (let ((addr (mime-read-field 'From h1))) + (let ((addr (car (mime-read-field 'From h1)))) (or (std11-full-name-string addr) (std11-address-string addr) "")) - (let ((addr (mime-read-field 'From h2))) + (let ((addr (car (mime-read-field 'From h2)))) (or (std11-full-name-string addr) (std11-address-string addr) "")) @@ -3951,8 +3984,10 @@ If SELECT-ARTICLES, only select those articles from GROUP." (gnus-adjust-marked-articles info)) ;; Kludge to avoid having cached articles nixed out in virtual groups. - (when (gnus-virtual-group-p group) - (setq cached gnus-newsgroup-cached)) + (setq cached + (if (gnus-virtual-group-p group) + gnus-newsgroup-cached + (gnus-cache-articles-in-group group))) (setq gnus-newsgroup-unreads (gnus-set-difference @@ -3993,10 +4028,6 @@ If SELECT-ARTICLES, only select those articles from GROUP." gnus-fetch-old-headers))) (gnus-message 5 "Fetching headers for %s...done" gnus-newsgroup-name) - ;; Kludge to avoid having cached articles nixed out in virtual groups. - (when cached - (setq gnus-newsgroup-cached cached)) - ;; Suppress duplicates? (when gnus-suppress-duplicates (gnus-dup-suppress-articles)) @@ -4013,6 +4044,11 @@ If SELECT-ARTICLES, only select those articles from GROUP." ;; Removed marked articles that do not exist. (gnus-update-missing-marks (gnus-sorted-complement fetched-articles articles)) + + ;; Kludge to avoid having cached articles nixed out in virtual groups. + (when cached + (setq gnus-newsgroup-cached cached)) + ;; We might want to build some more threads first. (when (and gnus-fetch-old-headers (eq gnus-headers-retrieved-by 'nov)) @@ -4065,15 +4101,20 @@ If SELECT-ARTICLES, only select those articles from GROUP." (condition-case () (cond ((and (or (<= scored marked) (= scored number)) - (numberp gnus-large-newsgroup) + (natnump gnus-large-newsgroup) (> number gnus-large-newsgroup)) - (let ((input - (read-string - (format - "How many articles from %s (default %d): " - (gnus-limit-string gnus-newsgroup-name 35) - number)))) - (if (string-match "^[ \t]*$" input) number input))) + (let* ((minibuffer-setup-hook (append + minibuffer-setup-hook + '(beginning-of-line))) + (input (read-string + (format + "How many articles from %s (max %d): " + (gnus-limit-string gnus-newsgroup-name 35) + number) + (number-to-string gnus-large-newsgroup)))) + (if (string-match "^[ \t]*$" input) + number + input))) ((and (> scored marked) (< scored number) (> (- scored number) 20)) (let ((input @@ -4186,13 +4227,14 @@ If SELECT-ARTICLES, only select those articles from GROUP." (uncompressed '(score bookmark killed)) type list newmarked symbol delta-marks) (when info - ;; Add all marks lists that are non-nil to the list of marks lists. + ;; Add all marks lists to the list of marks lists. (while (setq type (pop types)) - (when (setq list (symbol-value + (setq list (symbol-value (setq symbol (intern (format "gnus-newsgroup-%s" (car type)))))) + (when list ;; Get rid of the entries of the articles that have the ;; default score. (when (and (eq (cdr type) 'score) @@ -4207,30 +4249,35 @@ If SELECT-ARTICLES, only select those articles from GROUP." (setcdr prev (cdr arts)) (setq prev arts)) (setq arts (cdr arts))) - (setq list (cdr all)))) - - (when (gnus-check-backend-function 'request-set-mark - gnus-newsgroup-name) - ;; score & bookmark are not proper flags (they are cons cells) - ;; cache is a internal gnus flag - (unless (memq (cdr type) '(cache score bookmark)) - (let* ((old (cdr (assq (cdr type) (gnus-info-marks info)))) - (del (gnus-remove-from-range old list)) - (add (gnus-remove-from-range list old))) - (if add - (push (list add 'add (list (cdr type))) delta-marks)) - (if del - (push (list del 'del (list (cdr type))) delta-marks))))) - + (setq list (cdr all))))) + + (when (gnus-check-backend-function 'request-set-mark + gnus-newsgroup-name) + ;; uncompressed:s are not proper flags (they are cons cells) + ;; cache is a internal gnus flag + (unless (memq (cdr type) (cons 'cache uncompressed)) + (let* ((old (cdr (assq (cdr type) (gnus-info-marks info)))) + (list (gnus-compress-sequence (sort list '<))) + (del (gnus-remove-from-range old list)) + (add (gnus-remove-from-range list old))) + (if add + (push (list add 'add (list (cdr type))) delta-marks)) + (if del + (push (list del 'del (list (cdr type))) delta-marks))))) + + (when list (push (cons (cdr type) (if (memq (cdr type) uncompressed) list (gnus-compress-sequence (set symbol (sort list '<)) t))) newmarked))) + - (if delta-marks - (gnus-request-set-mark gnus-newsgroup-name delta-marks)) - + (when delta-marks + (unless (gnus-check-group gnus-newsgroup-name) + (error "Can't open server for %s" gnus-newsgroup-name)) + (gnus-request-set-mark gnus-newsgroup-name delta-marks)) + ;; Enter these new marks into the info of the group. (if (nthcdr 3 info) (setcar (nthcdr 3 info) newmarked) @@ -4448,15 +4495,6 @@ The resulting hash table is returned, or nil if no Xrefs were found." ;; Update the group buffer. (gnus-group-update-group group t))))) -(defun gnus-methods-equal-p (m1 m2) - (let ((m1 (or m1 gnus-select-method)) - (m2 (or m2 gnus-select-method))) - (or (equal m1 m2) - (and (eq (car m1) (car m2)) - (or (not (memq 'address (assoc (symbol-name (car m1)) - gnus-valid-select-methods))) - (equal (nth 1 m1) (nth 1 m2))))))) - (defvar gnus-newsgroup-none-id 0) (defun gnus-get-newsgroup-headers (&optional dependencies force-new) @@ -5088,22 +5126,24 @@ With arg, turn line truncation on iff arg is positive." (redraw-display)) (defun gnus-summary-reselect-current-group (&optional all rescan) - "Exit and then reselect the current newsgroup. + "Rescan the current newsgroup, exit and then reselect it. The prefix argument ALL means to select all articles." (interactive "P") (when (gnus-ephemeral-group-p gnus-newsgroup-name) (error "Ephemeral groups can't be reselected")) (let ((current-subject (gnus-summary-article-number)) (group gnus-newsgroup-name)) + (save-excursion + (set-buffer gnus-group-buffer) + ;; We have to adjust the point of group mode buffer because + ;; point was moved to the next unread newsgroup by exiting. + (gnus-summary-jump-to-group group) + (when rescan + (save-excursion + (gnus-group-get-new-news-this-group 1)))) (setq gnus-newsgroup-begin nil) (gnus-summary-exit) - ;; We have to adjust the point of group mode buffer because - ;; point was moved to the next unread newsgroup by exiting. - (gnus-summary-jump-to-group group) - (when rescan - (save-excursion - (gnus-group-get-new-news-this-group 1))) - (gnus-group-read-group all t) + (gnus-group-read-group all t group) (gnus-summary-goto-subject current-subject nil t))) (defun gnus-summary-rescan-group (&optional all) @@ -6955,28 +6995,31 @@ If ARG is a negative number, hide the unwanted header lines." (interactive "P") (save-excursion (set-buffer gnus-article-buffer) - (let* ((buffer-read-only nil) - (inhibit-point-motion-hooks t) - (hidden (text-property-any - (goto-char (point-min)) (search-forward "\n\n") - 'invisible t)) - e) - (goto-char (point-min)) - (when (search-forward "\n\n" nil t) - (delete-region (point-min) (1- (point)))) - (goto-char (point-min)) - (save-excursion - (set-buffer gnus-original-article-buffer) + (save-restriction + (let* ((buffer-read-only nil) + (inhibit-point-motion-hooks t) + hidden e) + (save-restriction + (article-narrow-to-head) + (setq hidden (gnus-article-hidden-text-p 'headers))) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (delete-region (point-min) (1- (point)))) (goto-char (point-min)) - (setq e (1- (or (search-forward "\n\n" nil t) (point-max))))) - (insert-buffer-substring gnus-original-article-buffer 1 e) - (let ((article-inhibit-hiding t)) - (gnus-run-hooks 'gnus-article-display-hook)) - (if (or (not hidden) (and (numberp arg) (< arg 0))) - (let ((gnus-treat-hide-headers nil) - (gnus-treat-hide-boring-headers nil)) - (gnus-treat-article 'head)) - (gnus-treat-article 'head))))) + (save-excursion + (set-buffer gnus-original-article-buffer) + (goto-char (point-min)) + (setq e (1- (or (search-forward "\n\n" nil t) (point-max))))) + (insert-buffer-substring gnus-original-article-buffer 1 e) + (save-restriction + (narrow-to-region (point-min) (point)) + (article-decode-encoded-words) + (if (or hidden + (and (numberp arg) (< arg 0))) + (let ((gnus-treat-hide-headers nil) + (gnus-treat-hide-boring-headers nil)) + (gnus-treat-article 'head)) + (gnus-treat-article 'head))))))) (defun gnus-summary-show-all-headers () "Make all header lines visible." @@ -7057,6 +7100,9 @@ and `request-accept' functions." (crosspost "Crosspost" "Crossposting"))) (copy-buf (save-excursion (nnheader-set-temp-buffer " *copy article*"))) + (default-marks gnus-article-mark-lists) + (no-expire-marks (delete '(expirable . expire) + (copy-sequence gnus-article-mark-lists))) art-group to-method new-xref article to-groups) (unless (assq action names) (error "Unknown action %s" action)) @@ -7162,10 +7208,10 @@ and `request-accept' functions." (list (cdr art-group))))) ;; Copy any marks over to the new group. - (let ((marks gnus-article-mark-lists) + (let ((marks (if (gnus-group-auto-expirable-p to-group) + default-marks + no-expire-marks)) (to-article (cdr art-group))) - (unless (gnus-group-auto-expirable-p to-group) - (setq marks (delete '(expirable . expire) marks))) ;; See whether the article is to be put in the cache. (when gnus-use-cache @@ -7370,6 +7416,8 @@ This will be the case if the article has both been mailed and posted." ;; There are expirable articles in this group, so we run them ;; through the expiry process. (gnus-message 6 "Expiring articles...") + (unless (gnus-check-group gnus-newsgroup-name) + (error "Can't open server for %s" gnus-newsgroup-name)) ;; The list of articles that weren't expired is returned. (save-excursion (if expiry-wait @@ -7449,22 +7497,21 @@ This will have permanent effect only in mail groups. If FORCE is non-nil, allow editing of articles even in read-only groups." (interactive "P") - (save-excursion - (set-buffer gnus-summary-buffer) - (gnus-set-global-variables) - (when (and (not force) - (gnus-group-read-only-p)) - (error "The current newsgroup does not support article editing")) - ;; Select article if needed. - (unless (eq (gnus-summary-article-number) - gnus-current-article) - (gnus-summary-select-article t)) - (gnus-article-date-original) - (gnus-article-edit-article - `(lambda (no-highlight) - (gnus-summary-edit-article-done - ,(or (mail-header-references gnus-current-headers) "") - ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))) + (let ((mail-parse-charset gnus-newsgroup-charset)) + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-set-global-variables) + (when (and (not force) + (gnus-group-read-only-p)) + (error "The current newsgroup does not support article editing")) + (gnus-summary-show-article t) + (gnus-article-edit-article + 'ignore + `(lambda (no-highlight) + (let ((mail-parse-charset ',gnus-newsgroup-charset)) + (gnus-summary-edit-article-done + ,(or (mail-header-references gnus-current-headers) "") + ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))))) (defalias 'gnus-summary-edit-article-postpone 'gnus-article-edit-exit) @@ -7479,7 +7526,7 @@ groups." (if (and (not read-only) (not (gnus-request-replace-article (cdr gnus-article-current) (car gnus-article-current) - (current-buffer)))) + (current-buffer) t))) (error "Couldn't replace article") ;; Update the summary buffer. (if (and references @@ -8544,11 +8591,17 @@ Argument REVERSE means reverse order." (gnus-summary-sort 'score reverse)) (defun gnus-summary-sort-by-lines (&optional reverse) - "Sort the summary buffer by article length. + "Sort the summary buffer by the number of lines. Argument REVERSE means reverse order." (interactive "P") (gnus-summary-sort 'lines reverse)) +(defun gnus-summary-sort-by-chars (&optional reverse) + "Sort the summary buffer by article length. +Argument REVERSE means reverse order." + (interactive "P") + (gnus-summary-sort 'chars reverse)) + (defun gnus-summary-sort (predicate reverse) "Sort summary buffer by PREDICATE. REVERSE means reverse order." (let* ((thread (intern (format "gnus-thread-sort-by-%s" predicate))) @@ -8717,7 +8770,7 @@ save those articles instead." split-name)) ((consp result) (setq split-name (append result split-name))))))))) - split-name)) + (nreverse split-name))) (defun gnus-valid-move-group-p (group) (and (boundp group) @@ -9073,6 +9126,8 @@ save those articles instead." (let ((del (gnus-remove-from-range (gnus-info-read info) read)) (add (gnus-remove-from-range read (gnus-info-read info)))) (when (or add del) + (unless (gnus-check-group group) + (error "Can't open server for %s" group)) (gnus-request-set-mark group (delq nil (list (if add (list add 'add '(read))) (if del (list del 'del '(read))))))))) @@ -9139,6 +9194,100 @@ save those articles instead." )) +;;; @ for message/rfc822 +;;; + +(defun gnus-mime-extract-message/rfc822 (entity situation) + (let (group article num cwin swin cur) + (with-current-buffer (mime-entity-buffer entity) + (save-restriction + (narrow-to-region (mime-entity-body-start entity) + (mime-entity-body-end entity)) + (setq group (or (cdr (assq 'group situation)) + (completing-read "Group: " + gnus-active-hashtb + nil + (gnus-read-active-file-p) + gnus-newsgroup-name)) + article (gnus-request-accept-article group) + ) + )) + (when (and (consp article) + (numberp (setq article (cdr article)))) + (setq num (1+ (or (cdr (assq 'number situation)) 0)) + cwin (get-buffer-window (current-buffer) t) + ) + (save-window-excursion + (if (setq swin (get-buffer-window gnus-summary-buffer t)) + (select-window swin) + (set-buffer gnus-summary-buffer) + ) + (setq cur gnus-current-article) + (forward-line num) + (let (gnus-show-threads) + (gnus-summary-goto-subject article t) + ) + (gnus-summary-clear-mark-forward 1) + (gnus-summary-goto-subject cur) + ) + (when (and cwin (window-frame cwin)) + (select-frame (window-frame cwin)) + ) + (when (boundp 'mime-acting-situation-to-override) + (set-alist 'mime-acting-situation-to-override + 'group + group) + (set-alist 'mime-acting-situation-to-override + 'after-method + `(progn + (save-current-buffer + (set-buffer gnus-group-buffer) + (gnus-activate-group ,group) + ) + (gnus-summary-goto-article ,cur + gnus-show-all-headers) + )) + (set-alist 'mime-acting-situation-to-override + 'number num) + ) + ))) + +(mime-add-condition + 'action '((type . message)(subtype . rfc822) + (major-mode . gnus-original-article-mode) + (method . gnus-mime-extract-message/rfc822) + (mode . "extract") + )) + +(mime-add-condition + 'action '((type . message)(subtype . news) + (major-mode . gnus-original-article-mode) + (method . gnus-mime-extract-message/rfc822) + (mode . "extract") + )) + +(defun gnus-mime-extract-multipart (entity situation) + (let ((children (mime-entity-children entity)) + mime-acting-situation-to-override + f) + (while children + (mime-play-entity (car children) + (cons (assq 'mode situation) + mime-acting-situation-to-override)) + (setq children (cdr children))) + (if (setq f (cdr (assq 'after-method + mime-acting-situation-to-override))) + (eval f) + ))) + +(mime-add-condition + 'action '((type . multipart) + (method . gnus-mime-extract-multipart) + (mode . "extract") + ) + 'with-default) + + ;;; @ end ;;; @@ -9148,7 +9297,8 @@ save those articles instead." (gnus-group-real-name gnus-newsgroup-name)))) (setq gnus-newsgroup-charset (or (and gnus-newsgroup-name - (or (gnus-group-find-parameter gnus-newsgroup-name 'charset) + (or (gnus-group-find-parameter gnus-newsgroup-name + 'charset) (let ((alist gnus-group-charset-alist) elem (charset nil)) (while (setq elem (pop alist)) @@ -9203,6 +9353,115 @@ treated as multipart/mixed." (gnus-summary-show-article)) (gnus-summary-show-article))) +;;; +;;; with article +;;; + +(defmacro gnus-with-article (article &rest forms) + "Select ARTICLE and perform FORMS in the original article buffer. +Then replace the article with the result." + `(progn + ;; We don't want the article to be marked as read. + (let (gnus-mark-article-hook) + (gnus-summary-select-article t t nil ,article)) + (set-buffer gnus-original-article-buffer) + ,@forms + (if (not (gnus-check-backend-function + 'request-replace-article (car gnus-article-current))) + (gnus-message 5 "Read-only group; not replacing") + (unless (gnus-request-replace-article + ,article (car gnus-article-current) + (current-buffer) t) + (error "Couldn't replace article"))) + ;; The cache and backlog have to be flushed somewhat. + (when gnus-keep-backlog + (gnus-backlog-remove-article + (car gnus-article-current) (cdr gnus-article-current))) + (when gnus-use-cache + (gnus-cache-update-article + (car gnus-article-current) (cdr gnus-article-current))))) + +(put 'gnus-with-article 'lisp-indent-function 1) +(put 'gnus-with-article 'edebug-form-spec '(form body)) + +;;; +;;; Generic summary marking commands +;;; + +(defvar gnus-summary-marking-alist + '((read gnus-del-mark "d") + (unread gnus-unread-mark "u") + (ticked gnus-ticked-mark "!") + (dormant gnus-dormant-mark "?") + (expirable gnus-expirable-mark "e")) + "An alist of names/marks/keystrokes.") + +(defvar gnus-summary-generic-mark-map (make-sparse-keymap)) +(defvar gnus-summary-mark-map) + +(defun gnus-summary-make-all-marking-commands () + (define-key gnus-summary-mark-map "M" gnus-summary-generic-mark-map) + (dolist (elem gnus-summary-marking-alist) + (apply 'gnus-summary-make-marking-command elem))) + +(defun gnus-summary-make-marking-command (name mark keystroke) + (let ((map (make-sparse-keymap))) + (define-key gnus-summary-generic-mark-map keystroke map) + (dolist (lway `((next "next" next nil "n") + (next-unread "next unread" next t "N") + (prev "previous" prev nil "p") + (prev-unread "previous unread" prev t "P") + (nomove "" nil nil ,keystroke))) + (let ((func (gnus-summary-make-marking-command-1 + mark (car lway) lway name))) + (setq func (eval func)) + (define-key map (nth 4 lway) func))))) + +(defun gnus-summary-make-marking-command-1 (mark way lway name) + `(defun ,(intern + (format "gnus-summary-put-mark-as-%s%s" + name (if (eq way 'nomove) + "" + (concat "-" (symbol-name way))))) + (n) + ,(format + "Mark the current article as %s%s. +If N, the prefix, then repeat N times. +If N is negative, move in reverse order. +The difference between N and the actual number of articles marked is +returned." + name (cadr lway)) + (interactive "p") + (gnus-summary-generic-mark n ,mark ',(nth 2 lway) ,(nth 3 lway)))) + +(defun gnus-summary-generic-mark (n mark move unread) + "Mark N articles with MARK." + (unless (eq major-mode 'gnus-summary-mode) + (error "This command can only be used in the summary buffer")) + (gnus-summary-show-thread) + (let ((nummove + (cond + ((eq move 'next) 1) + ((eq move 'prev) -1) + (t 0)))) + (if (zerop nummove) + (setq n 1) + (when (< n 0) + (setq n (abs n) + nummove (* -1 nummove)))) + (while (and (> n 0) + (gnus-summary-mark-article nil mark) + (zerop (gnus-summary-next-subject nummove unread t))) + (setq n (1- n))) + (when (/= 0 n) + (gnus-message 7 "No more %sarticles" (if mark "" "unread "))) + (gnus-summary-recenter) + (gnus-summary-position-point) + (gnus-set-mode-line 'summary) + n)) + +(gnus-summary-make-all-marking-commands) + (gnus-ems-redefine) (provide 'gnus-sum)