summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/misc/gnus.texi3
-rw-r--r--lisp/ChangeLog5
-rw-r--r--lisp/calendar/time-date.el20
-rw-r--r--lisp/gnus/ChangeLog124
-rw-r--r--lisp/gnus/gnus-group.el186
-rw-r--r--lisp/gnus/gnus-html.el158
-rw-r--r--lisp/gnus/gnus-int.el9
-rw-r--r--lisp/gnus/gnus-start.el14
-rw-r--r--lisp/gnus/gnus-sum.el4
-rw-r--r--lisp/gnus/gnus.el12
-rw-r--r--lisp/gnus/nnimap.el144
-rw-r--r--lisp/gnus/nnmail.el24
12 files changed, 426 insertions, 277 deletions
diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi
index 52c8bb642f0..3085b338e97 100644
--- a/doc/misc/gnus.texi
+++ b/doc/misc/gnus.texi
@@ -1996,8 +1996,7 @@ functions for snarfing info on the group.
@vindex gnus-group-update-hook
@findex gnus-group-highlight-line
@code{gnus-group-update-hook} is called when a group line is changed.
-It will not be called when @code{gnus-visual} is @code{nil}. This hook
-calls @code{gnus-group-highlight-line} by default.
+It will not be called when @code{gnus-visual} is @code{nil}.
@node Group Maneuvering
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 11b46901563..49393728f07 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,8 @@
+2010-09-22 Dan Christensen <jdc@uwo.ca>
+
+ * calendar/time-date.el (date-to-time): Try using parse-time-string
+ first before using the slower timezone-make-date-arpa-standard.
+
2010-09-22 Katsumi Yamaoka <yamaoka@jpl.org>
* calendar/time-date.el (format-seconds): Comment fix.
diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el
index 7a0cafea80f..0c435714306 100644
--- a/lisp/calendar/time-date.el
+++ b/lisp/calendar/time-date.el
@@ -97,20 +97,20 @@ and type 2 is the list (HIGH LOW MICRO)."
(autoload 'timezone-make-date-arpa-standard "timezone")
;;;###autoload
+;; `parse-time-string' isn't sufficiently general or robust. It fails
+;; to grok some of the formats that timezone does (e.g. dodgy
+;; post-2000 stuff from some Elms) and either fails or returns bogus
+;; values. timezone-make-date-arpa-standard should help.
(defun date-to-time (date)
"Parse a string DATE that represents a date-time and return a time value.
If DATE lacks timezone information, GMT is assumed."
(condition-case ()
- (apply 'encode-time
- (parse-time-string
- ;; `parse-time-string' isn't sufficiently general or
- ;; robust. It fails to grok some of the formats that
- ;; timezone does (e.g. dodgy post-2000 stuff from some
- ;; Elms) and either fails or returns bogus values. Lars
- ;; reverted this change, but that loses non-trivially
- ;; often for me. -- fx
- (timezone-make-date-arpa-standard date)))
- (error (error "Invalid date: %s" date))))
+ (apply 'encode-time (parse-time-string date))
+ (error (condition-case ()
+ (apply 'encode-time
+ (parse-time-string
+ (timezone-make-date-arpa-standard date)))
+ (error (error "Invalid date: %s" date))))))
;; Bit of a mess. Emacs has float-time since at least 21.1.
;; This file is synced to Gnus, and XEmacs packages may have been written
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 1a695c9f039..db46e04b96a 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,9 +1,112 @@
+2010-09-22 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-parse-flags): Parse the data in any order.
+ (nnimap-update-info): Fix up code slightly.
+
+ * gnus-int.el (gnus-open-server): Add tracing for performance
+ debugging.
+
+ * gnus-group.el (gnus-group-highlight-line): Typo fix: beg, not start.
+ (gnus-group-insert-group-line): Pass the real group name so that it
+ gets the right data.
+
+ * gnus-start.el (gnus-get-unread-articles): Don't have
+ `gnus-get-unread-articles-in-group' update info, since that can be
+ really slow and doesn't seem to be needed?
+
+2010-09-22 Dan Christensen <jdc@uwo.ca>
+
+ * time-date.el (date-to-time): Try using parse-time-string first before
+ using the slower timezone-make-date-arpa-standard.
+
+2010-09-22 Julien Danjou <julien@danjou.info>
+
+ * gnus-group.el (gnus-group-insert-group-line): Call
+ gnus-group-highlight-line.
+ (gnus-group-update-hook): Remove gnus-group-highlight-line from the
+ default hook list.
+ (gnus-group-update-eval-form): Add new function.
+ (gnus-group-highlight-line): Use gnus-group-update-eval-form.
+ (gnus-group-get-icon): Use gnus-group-update-eval-form.
+
+2010-09-22 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-request-expire-articles): If nnmail-expiry-wait is
+ immediate, then expire all articles.
+ (nnimap-update-info): Fix off-by-one errors.
+ (nnimap-flags-to-marks): Would return no marks lists for group with no
+ flags. Instead return the other data.
+
+2010-09-22 Julien Danjou <julien@danjou.info>
+
+ * gnus-group.el (gnus-group-get-icon): Renamed gnus-group-add-icon that
+ Only return an icon.
+ (gnus-group-insert-group-line): Compute icon to return.
+
+ * gnus-html.el (gnus-html-image-automatic-caching): Add custom
+ variable.
+ (gnus-html-image-fetched): Only cache if
+ gnus-html-image-automatic-caching is set.
+ (gnus-html-image-fetched): Check for errors.
+
+2010-09-22 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-start.el (gnus-read-active-for-groups): Only run -request-scan
+ once per method on `g'. This ensures that backends like nnfolder don't
+ open all their folders.
+
+ * nnimap.el (nnimap-split-incoming-mail): Delete 'junk.
+ (nnimap-request-list): Nix out group in the correct buffer.
+ (nnimap-parse-flags): Implement by using `read' instead of
+ hand-parsing.
+ (nnimap-flags-to-marks): Pass on permanent-flags.
+ (nnimap-make-process-buffer): Record the server name.
+ (nnimap-parse-flags): Fix typo.
+ (nnimap-request-scan): Run split on the server in general, not just a
+ single group.
+
+ * nnmail.el (nnmail-split-incoming): Take an optional junk-func
+ parameter, and propagate this downwards.
+
+ * nnimap.el (nnimap-request-list): Set the current nnimap group to nil,
+ since EXAMINE changes it on the server.
+
+ * gnus-int.el (gnus-request-expire-articles): Inhibit the daemon, since
+ this command might take a while.
+
+2010-09-22 Julien Danjou <julien@danjou.info>
+
+ * gnus-html.el (gnus-html-rescale-image): Use window-inside-pixel-edges
+ rather than window-pixel-edges.
+ (gnus-html-put-image): Stop using markers. They are harmful if you have
+ 2 images side-by-side, they can't be properly update on text deletion.
+ Using text-property is safer here.
+ (gnus-html-image-fetched): Search also for \r\n\r\n to get the start of
+ data.
+
+2010-09-22 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * nnimap.el (nnimap-expunge-inbox): Removed.
+ (nnimap-mark-and-expunge-incoming): Use nnimap-expunge instead.
+ (nnimap-expunge): Flip default to t.
+
+ * gnus.el (gnus-method-to-server): Don't push things to the cache
+ unless it's unique.
+ (gnus-server-to-method): Ditto.
+
2010-09-22 Teodor Zlatanov <tzz@lifelogs.com>
* nnimap.el (nnimap-delete-article): Tell user if expunge won't happen.
2010-09-22 Julien Danjou <julien@danjou.info>
+ * gnus-html.el (gnus-html-get-image-data): Search also for \r\n\r\n to
+ get the start of data.
+ (gnus-html-encode-url): Add this function to encode special chars in
+ URL.
+ (gnus-html-wash-images): Use gnus-html-encode-url to encode URL.
+ (gnus-html-prefetch-images): Use gnus-html-encode-url to encode URL.
+
* gnus-group.el (gnus-group-update-hook): Call gnus-group-add-icon by
default.
(gnus-group-add-icon): Move to gnus-group.el, and rewrite so it works.
@@ -19,6 +122,19 @@
* nnir.el (nnir-run-find-grep)
* pop3.el (pop3-list): Use 3rd arg of split-string.
+2010-09-21 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-update-marks): Add sanity check to not delete marks
+ outside the active range. Suggested by Dan Christensen.
+
+ * gnus-start.el (gnus-get-unread-articles): Get the extended method
+ slightly later to avoid double-getting it.
+
+ * nnml.el (nnml-generate-nov-file): Fix variable name clobbering from
+ previous patch.
+
+ * gnus-sum.el (gnus-adjust-marked-articles): Fix another typo.
+
2010-09-21 Adam Sjøgren <asjo@koldfront.dk>
* gnus-sum.el (gnus-adjust-marked-articles): Fix typo.
@@ -103,6 +219,9 @@
2010-09-20 Lars Magne Ingebrigtsen <larsi@gnus.org>
+ * gnus-group.el (gnus-group-line-format-alist): Have the ?U (unseen)
+ spec inser "*" if the group isn't active instead of 0.
+
* nnimap.el (nnimap-request-group): Don't select the imap buffer before
opening the server.
(nnimap-request-delete-group): Implement group deletion.
@@ -369,7 +488,7 @@
* dgnushack.el: Define netrc-credentials.
-2010-09-17 Julien Danjou <julien@danjou.info> (tiny fix)
+2010-09-17 Julien Danjou <julien@danjou.info>
* mm-decode.el (mm-text-html-renderer): Document gnus-article-html.
@@ -439,6 +558,9 @@
2010-09-14 Lars Magne Ingebrigtsen <larsi@gnus.org>
+ * gnus-registry.el (gnus-registry-install-shortcuts): The second
+ parameter to unintern is mandatory-ish in Emacs 24.
+
* gnus-html.el (gnus-html-schedule-image-fetching)
(gnus-html-prefetch-images): Check for curl before using it.
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el
index 5934a19ae2d..5aa64e8eed7 100644
--- a/lisp/gnus/gnus-group.el
+++ b/lisp/gnus/gnus-group.el
@@ -292,14 +292,8 @@ If you want to modify the group buffer, you can use this hook."
:group 'gnus-exit
:type 'hook)
-(defcustom gnus-group-update-hook '(gnus-group-highlight-line gnus-group-add-icon)
- "Hook called when a group line is changed.
-The hook will not be called if `gnus-visual' is nil.
-
-The default functions `gnus-group-highlight-line' will highlight
-the line according to the `gnus-group-highlight' variable, and
-`gnus-group-add-icon' will add an icon according to
-`gnus-group-icon-list'"
+(defcustom gnus-group-update-hook nil
+ "Hook called when a group line is changed."
:group 'gnus-group-visual
:type 'hook)
@@ -429,7 +423,6 @@ group: The name of the group.
unread: The number of unread articles in the group.
method: The select method used.
mailp: Whether it's a mail group or not.
-newsp: Whether it's a news group or not
level: The level of the group.
score: The score of the group.
ticked: The number of ticked articles."
@@ -1579,7 +1572,7 @@ if it is a string, only list groups matching REGEXP."
?m ? ))
(gnus-tmp-moderated-string
(if (eq gnus-tmp-moderated ?m) "(m)" ""))
- (gnus-tmp-group-icon (propertize " " 'gnus-group-icon t))
+ (gnus-tmp-group-icon (gnus-group-get-icon gnus-tmp-qualified-group))
(gnus-tmp-news-server (or (cadr gnus-tmp-method) ""))
(gnus-tmp-news-method (or (car gnus-tmp-method) ""))
(gnus-tmp-news-method-string
@@ -1626,108 +1619,85 @@ if it is a string, only list groups matching REGEXP."
'gnus-tool-bar-update))
(forward-line -1)
(when (inline (gnus-visual-p 'group-highlight 'highlight))
- (gnus-run-hooks 'gnus-group-update-hook))
+ (gnus-group-highlight-line gnus-tmp-group beg end))
+ (gnus-run-hooks 'gnus-group-update-hook)
(forward-line)
;; Allow XEmacs to remove front-sticky text properties.
(gnus-group-remove-excess-properties)))
-(defun gnus-group-highlight-line ()
- "Highlight the current line according to `gnus-group-highlight'."
- (let* ((list gnus-group-highlight)
- (p (point))
- (end (point-at-eol))
- ;; now find out where the line starts and leave point there.
- (beg (progn (beginning-of-line) (point)))
- (group (gnus-group-group-name))
- (entry (gnus-group-entry group))
- (unread (if (numberp (car entry)) (car entry) 0))
- (active (gnus-active group))
- (total (if active (1+ (- (cdr active) (car active))) 0))
- (info (nth 2 entry))
- (method (inline (gnus-server-get-method group (gnus-info-method info))))
- (marked (gnus-info-marks info))
- (mailp (apply 'append
- (mapcar
- (lambda (x)
- (memq x (assoc (symbol-name
- (car (or method gnus-select-method)))
- gnus-valid-select-methods)))
- '(mail post-mail))))
- (level (or (gnus-info-level info) gnus-level-killed))
- (score (or (gnus-info-score info) 0))
- (ticked (gnus-range-length (cdr (assq 'tick marked))))
- (group-age (gnus-group-timestamp-delta group))
- (inhibit-read-only t))
- ;; FIXME: http://thread.gmane.org/gmane.emacs.gnus.general/65451/focus=65465
- ;; ======================================================================
- ;; From: Richard Stallman
- ;; Subject: Re: Rewriting gnus-group-highlight-line (was: [...])
- ;; Cc: ding@gnus.org
- ;; Date: Sat, 27 Oct 2007 19:41:20 -0400
- ;; Message-ID: <E1IlvHM-0006TS-7t@fencepost.gnu.org>
- ;;
- ;; [...]
- ;; The kludge is that the alist elements contain expressions that refer
- ;; to local variables with short names. Perhaps write your own tiny
- ;; evaluator that handles just `and', `or', and numeric comparisons
- ;; and just a few specific variables.
- ;; ======================================================================
- ;;
- ;; Similar for other evaluated variables. Grep for risky-local-variable
- ;; to find them! -- rsteib
- ;;
- ;; Eval the cars of the lists until we find a match.
- (while (and list
- (not (eval (caar list))))
- (setq list (cdr list)))
- (let ((face (cdar list)))
- (unless (eq face (get-text-property beg 'face))
- (gnus-put-text-property-excluding-characters-with-faces
- beg end 'face
- (setq face (if (boundp face) (symbol-value face) face)))
- (gnus-extent-start-open beg)))
- (goto-char p)))
-
-(defun gnus-group-add-icon ()
- "Add an icon to the current line according to `gnus-group-icon-list'."
- (save-excursion
- (let* ((end (line-end-position))
- ;; now find out where the line starts and leave point there.
- (beg (line-beginning-position)))
- (save-restriction
- (narrow-to-region beg end)
- (goto-char beg)
- (let ((mystart (text-property-any beg end 'gnus-group-icon t)))
- (when mystart
- (let* ((group (gnus-group-group-name))
- (entry (gnus-group-entry group))
- (unread (if (numberp (car entry)) (car entry) 0))
- (active (gnus-active group))
- (total (if active (1+ (- (cdr active) (car active))) 0))
- (info (nth 2 entry))
- (method (gnus-server-get-method group (gnus-info-method info)))
- (marked (gnus-info-marks info))
- (mailp (memq 'mail (assoc (symbol-name
- (car (or method gnus-select-method)))
- gnus-valid-select-methods)))
- (level (or (gnus-info-level info) gnus-level-killed))
- (score (or (gnus-info-score info) 0))
- (ticked (gnus-range-length (cdr (assq 'tick marked))))
- (group-age (gnus-group-timestamp-delta group))
- (inhibit-read-only t)
- (list gnus-group-icon-list)
- (myend (next-single-property-change
- mystart 'gnus-group-icon)))
- (while (and list
- (not (eval (caar list))))
- (setq list (cdr list)))
- (when list
- (put-text-property
- mystart myend
- 'display
- (append
- (gnus-create-image (expand-file-name (cdar list)))
- '(:ascent center)))))))))))
+(defun gnus-group-update-eval-form (group list)
+ "Eval `car' of each element of LIST, and return the first that return t.
+Some value are bound so the form can use them."
+ (when list
+ (let* ((entry (gnus-group-entry group))
+ (unread (if (numberp (car entry)) (car entry) 0))
+ (active (gnus-active group))
+ (total (if active (1+ (- (cdr active) (car active))) 0))
+ (info (nth 2 entry))
+ (method (inline (gnus-server-get-method group (gnus-info-method info))))
+ (marked (gnus-info-marks info))
+ (mailp (apply 'append
+ (mapcar
+ (lambda (x)
+ (memq x (assoc (symbol-name
+ (car (or method gnus-select-method)))
+ gnus-valid-select-methods)))
+ '(mail post-mail))))
+ (level (or (gnus-info-level info) gnus-level-killed))
+ (score (or (gnus-info-score info) 0))
+ (ticked (gnus-range-length (cdr (assq 'tick marked))))
+ (group-age (gnus-group-timestamp-delta group)))
+ ;; FIXME: http://thread.gmane.org/gmane.emacs.gnus.general/65451/focus=65465
+ ;; ======================================================================
+ ;; From: Richard Stallman
+ ;; Subject: Re: Rewriting gnus-group-highlight-line (was: [...])
+ ;; Cc: ding@gnus.org
+ ;; Date: Sat, 27 Oct 2007 19:41:20 -0400
+ ;; Message-ID: <E1IlvHM-0006TS-7t@fencepost.gnu.org>
+ ;;
+ ;; [...]
+ ;; The kludge is that the alist elements contain expressions that refer
+ ;; to local variables with short names. Perhaps write your own tiny
+ ;; evaluator that handles just `and', `or', and numeric comparisons
+ ;; and just a few specific variables.
+ ;; ======================================================================
+ ;;
+ ;; Similar for other evaluated variables. Grep for risky-local-variable
+ ;; to find them! -- rsteib
+ ;;
+ ;; Eval the cars of the lists until we find a match.
+ (while (and list
+ (not (eval (caar list))))
+ (setq list (cdr list)))
+ list)))
+
+(defun gnus-group-highlight-line (group beg end)
+ "Highlight the current line according to `gnus-group-highlight'.
+GROUP is current group, and the line to highlight starts at START
+and ends at END."
+ (let ((face (cdar (gnus-group-update-eval-form
+ group
+ gnus-group-highlight))))
+ (unless (eq face (get-text-property beg 'face))
+ (let ((inhibit-read-only t))
+ (gnus-put-text-property-excluding-characters-with-faces
+ beg end 'face
+ (if (boundp face) (symbol-value face) face)))
+ (gnus-extent-start-open beg))))
+
+(defun gnus-group-get-icon (group)
+ "Return an icon for GROUP according to `gnus-group-icon-list'."
+ (if gnus-group-icon-list
+ (let ((image-path
+ (cdar (gnus-group-update-eval-form group gnus-group-icon-list))))
+ (if image-path
+ (propertize " "
+ 'display
+ (append
+ (gnus-create-image (expand-file-name image-path))
+ '(:ascent center)))
+ " "))
+ " "))
(defun gnus-group-update-group (group &optional visible-only)
"Update all lines where GROUP appear.
diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el
index 366c331c594..6879bb20be9 100644
--- a/lisp/gnus/gnus-html.el
+++ b/lisp/gnus/gnus-html.el
@@ -36,13 +36,20 @@
(require 'url)
(require 'url-cache)
(require 'xml)
+(require 'browse-url)
(defcustom gnus-html-image-cache-ttl (days-to-time 7)
- "Time in seconds used to cache the image on disk."
+ "Time used to determine if we should use images from the cache."
:version "24.1"
:group 'gnus-art
:type 'integer)
+(defcustom gnus-html-image-automatic-caching t
+ "Whether automatically cache retrieve images."
+ :version "24.1"
+ :group 'gnus-art
+ :type 'boolean)
+
(defcustom gnus-html-frame-width 70
"What width to use when rendering HTML."
:version "24.1"
@@ -81,6 +88,10 @@ fit these criteria."
(define-key map [tab] 'widget-forward)
map))
+(defun gnus-html-encode-url (url)
+ "Encode URL."
+ (browse-url-url-encode-chars url "[)$ ]"))
+
(defun gnus-html-cache-expired (url ttl)
"Check if URL is cached for more than TTL."
(cond (url-standalone-mode
@@ -155,7 +166,7 @@ fit these criteria."
(delete-region (match-beginning 0) (match-end 0)))
(setq end (point))
(when (string-match "src=\"\\([^\"]+\\)" parameters)
- (setq url (match-string 1 parameters))
+ (setq url (gnus-html-encode-url (match-string 1 parameters)))
(gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url)
(if (string-match "^cid:\\(.*\\)" url)
;; URLs with cid: have their content stashed in other
@@ -177,6 +188,7 @@ fit these criteria."
(let ((alt-text (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)"
parameters)
(xml-substitute-special (match-string 2 parameters)))))
+ (gnus-put-text-property start end 'gnus-image-url url)
(if (gnus-html-image-url-blocked-p
url
(if (buffer-live-p gnus-summary-buffer)
@@ -191,13 +203,9 @@ fit these criteria."
:keymap gnus-html-image-map
:button-keymap gnus-html-image-map)
(let ((overlay (gnus-make-overlay start end))
- (spec (list url
- (set-marker (make-marker) start)
- (set-marker (make-marker) end)
- alt-text)))
+ (spec (list url alt-text)))
(gnus-overlay-put overlay 'local-map gnus-html-image-map)
(gnus-overlay-put overlay 'gnus-image spec)
- (gnus-put-text-property start end 'gnus-image-url url)
(gnus-put-text-property
start end
'gnus-image spec)))
@@ -224,13 +232,9 @@ Use ALT-TEXT for the image string."
;; asynchronously.
(gnus-html-schedule-image-fetching
(current-buffer)
- (list url
- (set-marker (make-marker) start)
- (set-marker (make-marker) end)
- alt-text))
+ (list url alt-text))
;; It's already cached, so just insert it.
- (gnus-html-put-image (gnus-html-get-image-data url)
- start end url alt-text)))
+ (gnus-html-put-image (gnus-html-get-image-data url) url alt-text)))
(defun gnus-html-wash-tags ()
(let (tag parameters string start end images url)
@@ -347,22 +351,17 @@ Use ALT-TEXT for the image string."
(list buffer image))))
(defun gnus-html-image-fetched (status buffer image)
- (url-store-in-cache (current-buffer))
- (when (and (search-forward "\n\n" nil t)
- (buffer-live-p buffer)
- ;; If the `image' has no marker, do not replace anything
- (cadr image)
- ;; If the position of the marker is 1, then that
- ;; means that the text it was in has been deleted;
- ;; i.e., that the user has selected a different
- ;; article before the image arrived.
- (not (= (marker-position (cadr image))
- (with-current-buffer buffer
- (point-min)))))
- (let ((data (buffer-substring (point) (point-max))))
- (with-current-buffer buffer
- (let ((inhibit-read-only t))
- (gnus-html-put-image data (cadr image) (caddr image) (car image) (cadddr image))))))
+ "Callback function called when image has been fetched."
+ (unless (plist-get status :error)
+ (when gnus-html-image-automatic-caching
+ (url-store-in-cache (current-buffer)))
+ (when (and (or (search-forward "\n\n" nil t)
+ (search-forward "\r\n\r\n" nil t))
+ (buffer-live-p buffer))
+ (let ((data (buffer-substring (point) (point-max))))
+ (with-current-buffer buffer
+ (let ((inhibit-read-only t))
+ (gnus-html-put-image data (car image) (cadr image)))))))
(kill-buffer (current-buffer)))
(defun gnus-html-get-image-data (url)
@@ -371,54 +370,61 @@ Return a string with image data."
(with-temp-buffer
(mm-disable-multibyte)
(url-cache-extract (url-cache-create-filename url))
- (when (search-forward "\n\n" nil t)
+ (when (or (search-forward "\n\n" nil t)
+ (search-forward "\r\n\r\n" nil t))
(buffer-substring (point) (point-max)))))
-(defun gnus-html-put-image (data start end &optional url alt-text)
+(defun gnus-html-put-image (data url &optional alt-text)
(when (gnus-graphic-display-p)
- (let* ((image (ignore-errors
- (gnus-create-image data nil t)))
- (size (and image
- (if (featurep 'xemacs)
- (cons (glyph-width image) (glyph-height image))
- (image-size image t)))))
- (save-excursion
- (goto-char start)
- (let ((alt-text (or alt-text (buffer-substring-no-properties start end))))
- (if (and image
- ;; Kludge to avoid displaying 30x30 gif images, which
- ;; seems to be a signal of a broken image.
- (not (and (if (featurep 'xemacs)
- (glyphp image)
- (listp image))
- (eq (if (featurep 'xemacs)
- (let ((d (cdadar (specifier-spec-list
- (glyph-image image)))))
- (and (vectorp d)
- (aref d 0)))
- (plist-get (cdr image) :type))
- 'gif)
- (= (car size) 30)
- (= (cdr size) 30))))
- ;; Good image, add it!
- (let ((image (gnus-html-rescale-image image data size)))
- (delete-region start end)
- (gnus-put-image image alt-text 'external)
- (gnus-put-text-property start (point) 'help-echo alt-text)
- (gnus-overlay-put (gnus-make-overlay start (point)) 'local-map
- gnus-html-displayed-image-map)
- (gnus-put-text-property start (point) 'gnus-alt-text alt-text)
- (when url
- (gnus-put-text-property start (point) 'gnus-image-url url))
- (gnus-add-image 'external image)
- t)
- ;; Bad image, try to show something else
- (delete-region start end)
- (when (fboundp 'find-image)
- (setq image (find-image '((:type xpm :file "lock-broken.xpm"))))
- (gnus-put-image image alt-text 'internal)
- (gnus-add-image 'internal image))
- nil))))))
+ (let* ((start (text-property-any (point-min) (point-max) 'gnus-image-url url))
+ (end (when start
+ (next-single-property-change start 'gnus-image-url))))
+ ;; Image found?
+ (when start
+ (let* ((image
+ (ignore-errors
+ (gnus-create-image data nil t)))
+ (size (and image
+ (if (featurep 'xemacs)
+ (cons (glyph-width image) (glyph-height image))
+ (image-size image t)))))
+ (save-excursion
+ (goto-char start)
+ (let ((alt-text (or alt-text (buffer-substring-no-properties start end))))
+ (if (and image
+ ;; Kludge to avoid displaying 30x30 gif images, which
+ ;; seems to be a signal of a broken image.
+ (not (and (if (featurep 'xemacs)
+ (glyphp image)
+ (listp image))
+ (eq (if (featurep 'xemacs)
+ (let ((d (cdadar (specifier-spec-list
+ (glyph-image image)))))
+ (and (vectorp d)
+ (aref d 0)))
+ (plist-get (cdr image) :type))
+ 'gif)
+ (= (car size) 30)
+ (= (cdr size) 30))))
+ ;; Good image, add it!
+ (let ((image (gnus-html-rescale-image image data size)))
+ (delete-region start end)
+ (gnus-put-image image alt-text 'external)
+ (gnus-put-text-property start (point) 'help-echo alt-text)
+ (gnus-overlay-put (gnus-make-overlay start (point)) 'local-map
+ gnus-html-displayed-image-map)
+ (gnus-put-text-property start (point) 'gnus-alt-text alt-text)
+ (when url
+ (gnus-put-text-property start (point) 'gnus-image-url url))
+ (gnus-add-image 'external image)
+ t)
+ ;; Bad image, try to show something else
+ (when (fboundp 'find-image)
+ (delete-region start end)
+ (setq image (find-image '((:type xpm :file "lock-broken.xpm"))))
+ (gnus-put-image image alt-text 'internal)
+ (gnus-add-image 'internal image))
+ nil))))))))
(defun gnus-html-rescale-image (image data size)
(if (or (not (fboundp 'imagemagick-types))
@@ -426,7 +432,7 @@ Return a string with image data."
image
(let* ((width (car size))
(height (cdr size))
- (edges (window-pixel-edges (get-buffer-window (current-buffer))))
+ (edges (window-inside-pixel-edges (get-buffer-window (current-buffer))))
(window-width (truncate (* gnus-max-image-proportion
(- (nth 2 edges) (nth 0 edges)))))
(window-height (truncate (* gnus-max-image-proportion
@@ -472,7 +478,7 @@ This only works if the article in question is HTML."
gnus-blocked-images)))
(save-match-data
(while (re-search-forward "<img.*src=[\"']\\([^\"']+\\)" nil t)
- (let ((url (match-string 1)))
+ (let ((url (gnus-html-encode-url (match-string 1))))
(unless (gnus-html-image-url-blocked-p url blocked-images)
(when (gnus-html-cache-expired url gnus-html-image-cache-ttl)
(gnus-html-schedule-image-fetching nil
diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el
index 5ef58834df7..df7f979d538 100644
--- a/lisp/gnus/gnus-int.el
+++ b/lisp/gnus/gnus-int.el
@@ -226,10 +226,18 @@ If it is down, start it up (again)."
(eq (nth 1 (assoc method gnus-opened-servers))
'denied))
+(defvar gnus-backend-trace t)
+
(defun gnus-open-server (gnus-command-method)
"Open a connection to GNUS-COMMAND-METHOD."
(when (stringp gnus-command-method)
(setq gnus-command-method (gnus-server-to-method gnus-command-method)))
+ (when gnus-backend-trace
+ (with-current-buffer (get-buffer-create "*gnus trace*")
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert (format-time-string "%H:%M:%S")
+ (format " %S\n" gnus-command-method))))
(let ((elem (assoc gnus-command-method gnus-opened-servers))
(server (gnus-method-to-server-name gnus-command-method)))
;; If this method was previously denied, we just return nil.
@@ -601,6 +609,7 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
(defun gnus-request-expire-articles (articles group &optional force)
(let* ((gnus-command-method (gnus-find-method-for-group group))
+ (gnus-inhibit-demon t)
(not-deleted
(funcall
(gnus-get-function gnus-command-method 'request-expire-articles)
diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el
index c2f09a83c07..77ce8ee6324 100644
--- a/lisp/gnus/gnus-start.el
+++ b/lisp/gnus/gnus-start.el
@@ -1757,8 +1757,7 @@ If SCAN, request a scan of that group as well."
(when (gnus-check-backend-function
'retrieve-group-data-early (car method))
(when (gnus-check-backend-function 'request-scan (car method))
- (dolist (info infos)
- (gnus-request-scan (gnus-info-group info) method)))
+ (gnus-request-scan nil method))
(setcar (nthcdr 3 elem)
(gnus-retrieve-group-data-early method infos))))))
@@ -1770,8 +1769,7 @@ If SCAN, request a scan of that group as well."
(gnus-read-active-for-groups method infos early-data)
(dolist (info infos)
(inline (gnus-get-unread-articles-in-group
- info (gnus-active (gnus-info-group info))
- t))))))
+ info (gnus-active (gnus-info-group info))))))))
(gnus-message 6 "Checking new news...done")))
(defun gnus-method-rank (type method)
@@ -1806,8 +1804,7 @@ If SCAN, request a scan of that group as well."
(gnus-agent-save-active method))
((gnus-check-backend-function 'retrieve-groups (car method))
(when (gnus-check-backend-function 'request-scan (car method))
- (dolist (info infos)
- (gnus-request-scan (gnus-info-group info) method)))
+ (gnus-request-scan nil method))
(let (groups)
(gnus-read-active-file-2
(dolist (info infos (nreverse groups))
@@ -2055,10 +2052,7 @@ If SCAN, request a scan of that group as well."
(gnus-online method))
(not gnus-agent))
(gnus-check-backend-function 'request-scan (car method)))
- (if infos
- (dolist (info infos)
- (gnus-request-scan (gnus-info-group info) method))
- (gnus-request-scan nil method)))
+ (gnus-request-scan nil method))
(cond
((and (eq gnus-read-active-file 'some)
(gnus-check-backend-function 'retrieve-groups (car method))
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index 5997339a335..c4a721691f9 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -5976,6 +5976,10 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(when add
(push (list add 'add (list (cdr 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 (gnus-sorted-range-intersection
+ (gnus-active gnus-newsgroup-name) del))
(push (list del 'del (list (cdr type))) delta-marks))))
(when list
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index 3f18858fc64..42881e58ed6 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -3566,7 +3566,7 @@ that that variable is buffer-local to the summary buffers."
(nth 1 method))))
method)))
-(defsubst gnus-method-to-server (method &optional nocache)
+(defsubst gnus-method-to-server (method &optional nocache no-enter-cache)
(catch 'server-name
(setq method (or method gnus-select-method))
@@ -3592,7 +3592,9 @@ that that variable is buffer-local to the summary buffers."
(format "%s" (car method))
(format "%s:%s" (car method) (cadr method))))
(name-method (cons name method)))
- (unless (member name-method gnus-server-method-cache)
+ (when (and (not (member name-method gnus-server-method-cache))
+ (not no-enter-cache)
+ (not (assoc (car name-method) gnus-server-method-cache)))
(push name-method gnus-server-method-cache))
name)))
@@ -3634,11 +3636,13 @@ that that variable is buffer-local to the summary buffers."
(while alist
(setq method (gnus-info-method (pop alist)))
(when (and (not (stringp method))
- (equal server (gnus-method-to-server method)))
+ (equal server
+ (gnus-method-to-server method nil t)))
(setq match method
alist nil)))
match))))
- (when result
+ (when (and result
+ (not (assoc server gnus-server-method-cache)))
(push (cons server result) gnus-server-method-cache))
result)))
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index 63c61080a6a..7846aa2e2ad 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -62,11 +62,6 @@ Values are `ssl' and `network'.")
(defvoo nnimap-inbox nil
"The mail box where incoming mail arrives and should be split out of.")
-(defvoo nnimap-expunge-inbox nil
- "If non-nil, expunge the inbox after fetching mail.
-This is always done if the server supports UID EXPUNGE, but it's
-not done by default on servers that doesn't support that command.")
-
(defvoo nnimap-authenticator nil
"How nnimap authenticate itself to the server.
Possible choices are nil (use default methods) or `anonymous'.")
@@ -78,7 +73,11 @@ will fetch all parts that have types that match that string. A
likely value would be \"text/\" to automatically fetch all
textual parts.")
-(defvoo nnimap-expunge nil)
+(defvoo nnimap-expunge t
+ "If non-nil, expunge articles after deleting them.
+This is always done if the server supports UID EXPUNGE, but it's
+not done by default on servers that doesn't support that command.")
+
(defvoo nnimap-connection-alist nil)
@@ -92,14 +91,14 @@ textual parts.")
"Internal variable with default value for `nnimap-split-download-body'.")
(defstruct nnimap
- group process commands capabilities select-result newlinep)
+ group process commands capabilities select-result newlinep server)
(defvar nnimap-object nil)
(defvar nnimap-mark-alist
- '((read "\\Seen")
- (tick "\\Flagged")
- (reply "\\Answered")
+ '((read "\\Seen" %Seen)
+ (tick "\\Flagged" %Flagged)
+ (reply "\\Answered" %Answered)
(expire "gnus-expire")
(dormant "gnus-dormant")
(score "gnus-score")
@@ -213,7 +212,8 @@ textual parts.")
(buffer-disable-undo)
(gnus-add-buffer)
(set (make-local-variable 'after-change-functions) nil)
- (set (make-local-variable 'nnimap-object) (make-nnimap))
+ (set (make-local-variable 'nnimap-object)
+ (make-nnimap :server (nnoo-current-server 'nnimap)))
(push (list buffer (current-buffer)) nnimap-connection-alist)
(current-buffer)))
@@ -421,8 +421,9 @@ textual parts.")
(goto-char (point-max))
(cond
(marks
- (setq high (nth 3 (car marks))
- low (nth 4 (car marks))))
+ (let ((uidnext (nth 5 (car marks))))
+ (setq high (or (nth 3 (car marks)) (1- uidnext))
+ low (or (nth 4 (car marks)) uidnext))))
((re-search-backward "UIDNEXT \\([0-9]+\\)" nil t)
(setq high (1- (string-to-number (match-string 1)))
low 1)))))
@@ -502,7 +503,8 @@ textual parts.")
nil)
(t
(let ((deletable-articles
- (if force
+ (if (or force
+ (eq nnmail-expiry-wait 'immediate))
articles
(gnus-sorted-intersection
articles
@@ -587,9 +589,9 @@ textual parts.")
(deffoo nnimap-request-scan (&optional group server)
(when (and (nnimap-possibly-change-group nil server)
- (equal group nnimap-inbox)
nnimap-inbox
nnimap-split-methods)
+ (message "nnimap %s splitting mail..." server)
(nnimap-split-incoming-mail)))
(defun nnimap-marks-to-flags (marks)
@@ -667,6 +669,7 @@ textual parts.")
sequences responses)
(when groups
(with-current-buffer (nnimap-buffer)
+ (setf (nnimap-group nnimap-object) nil)
(dolist (group groups)
(push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t))
group)
@@ -716,6 +719,7 @@ textual parts.")
groups))
;; Then request the data.
(erase-buffer)
+ (setf (nnimap-group nnimap-object) nil)
(dolist (elem groups)
(if (and qresyncp
(nth 2 elem))
@@ -773,7 +777,8 @@ textual parts.")
(defun nnimap-update-info (info marks)
(when marks
- (destructuring-bind (existing flags high low uidnext start-article) marks
+ (destructuring-bind (existing flags high low uidnext start-article
+ permanent-flags) marks
(let ((group (gnus-info-group info))
(completep (and start-article
(= start-article 1))))
@@ -784,16 +789,18 @@ textual parts.")
(if high
(cons low high)
;; No articles in this group.
- (cons (1- uidnext) uidnext)))
- (setcdr (gnus-active group) high))
+ (cons uidnext (1- uidnext))))
+ (setcdr (gnus-active group) (or high (1- uidnext))))
+ (unless high
+ (setq high (1- uidnext)))
;; Then update the list of read articles.
(let* ((unread
(gnus-compress-sequence
(gnus-set-difference
(gnus-set-difference
existing
- (cdr (assoc "\\Seen" flags)))
- (cdr (assoc "\\Flagged" flags)))))
+ (cdr (assoc '%Seen flags)))
+ (cdr (assoc '%Flagged flags)))))
(read (gnus-range-difference
(cons start-article high) unread)))
(when (> start-article 1)
@@ -815,8 +822,10 @@ textual parts.")
(push (cons 'active (gnus-active group)) marks)))
(dolist (type (cdr nnimap-mark-alist))
(let ((old-marks (assoc (car type) marks))
- (new-marks (gnus-compress-sequence
- (cdr (assoc (cadr type) flags)))))
+ (new-marks
+ (gnus-compress-sequence
+ (cdr (or (assoc (caddr type) flags) ; %Flagged
+ (assoc (cadr type) flags)))))) ; "\Flagged"
(setq marks (delq old-marks marks))
(pop old-marks)
(when (and old-marks
@@ -838,12 +847,13 @@ textual parts.")
(push (list group info active) nnimap-current-infos))))
(defun nnimap-flags-to-marks (groups)
- (let (data group totalp uidnext articles start-article mark)
+ (let (data group totalp uidnext articles start-article mark permanent-flags)
(dolist (elem groups)
(setq group (car elem)
- uidnext (cadr elem)
- start-article (caddr elem)
- articles (cdddr elem))
+ uidnext (nth 1 elem)
+ start-article (nth 2 elem)
+ permanent-flags (nth 3 elem)
+ articles (nthcdr 4 elem))
(let ((high (caar articles))
marks low existing)
(dolist (article articles)
@@ -853,36 +863,49 @@ textual parts.")
(setq mark (assoc flag marks))
(if (not mark)
(push (list flag (car article)) marks)
- (setcdr mark (cons (car article) (cdr mark)))))
- (push (list group existing marks high low uidnext start-article)
- data))))
+ (setcdr mark (cons (car article) (cdr mark))))))
+ (push (list group existing marks high low uidnext start-article
+ permanent-flags)
+ data)))
data))
(defun nnimap-parse-flags (sequences)
(goto-char (point-min))
- (let (start end articles groups uidnext elems)
+ ;; Change \Delete etc to %Delete, so that the reader can read it.
+ (subst-char-in-region (point-min) (point-max)
+ ?\\ ?% t)
+ (let (start end articles groups uidnext elems permanent-flags)
(dolist (elem sequences)
(destructuring-bind (group-sequence flag-sequence totalp group) elem
+ (setq start (point))
;; The EXAMINE was successful.
(when (and (search-forward (format "\n%d OK " group-sequence) nil t)
(progn
(forward-line 1)
- (setq start (point))
- (if (re-search-backward "UIDNEXT \\([0-9]+\\)"
- (or end (point-min)) t)
- (setq uidnext (string-to-number (match-string 1)))
- (setq uidnext nil))
- (goto-char start))
+ (setq end (point))
+ (goto-char start)
+ (setq permanent-flags
+ (and (search-forward "PERMANENTFLAGS "
+ (or end (point-min)) t)
+ (read (current-buffer))))
+ (goto-char start)
+ (setq uidnext
+ (and (search-forward "UIDNEXT "
+ (or end (point-min)) t)
+ (read (current-buffer))))
+ (goto-char end)
+ (forward-line -1))
;; The UID FETCH FLAGS was successful.
(search-forward (format "\n%d OK " flag-sequence) nil t))
- (setq end (point))
- (goto-char start)
- (while (re-search-forward "^\\* [0-9]+ FETCH (\\(.*\\))" end t)
- (setq elems (nnimap-parse-line (match-string 1)))
- (push (cons (string-to-number (cadr (member "UID" elems)))
- (cadr (member "FLAGS" elems)))
+ (setq start (point))
+ (goto-char end)
+ (while (search-forward " FETCH " start t)
+ (setq elems (read (current-buffer)))
+ (push (cons (cadr (memq 'UID elems))
+ (cadr (memq 'FLAGS elems)))
articles))
- (push (nconc (list group uidnext totalp) articles) groups)
+ (push (nconc (list group uidnext totalp permanent-flags) articles)
+ groups)
(setq articles nil))))
groups))
@@ -1085,32 +1108,38 @@ textual parts.")
(nnmail-split-incoming (current-buffer)
#'nnimap-save-mail-spec
nil nil
- #'nnimap-dummy-active-number)
+ #'nnimap-dummy-active-number
+ #'nnimap-save-mail-spec)
(when nnimap-incoming-split-list
(let ((specs (nnimap-make-split-specs nnimap-incoming-split-list))
- sequences)
+ sequences junk-articles)
;; Create any groups that doesn't already exist on the
;; server first.
(dolist (spec specs)
- (unless (member (car spec) groups)
+ (when (and (not (member (car spec) groups))
+ (not (eq (car spec) 'junk)))
(nnimap-command "CREATE %S" (utf7-encode (car spec) t))))
;; Then copy over all the messages.
(erase-buffer)
(dolist (spec specs)
(let ((group (car spec))
(ranges (cdr spec)))
- (push (list (nnimap-send-command "UID COPY %s %S"
- (nnimap-article-ranges ranges)
- (utf7-encode group t))
- ranges)
- sequences)))
+ (if (eq group 'junk)
+ (setq junk-articles ranges)
+ (push (list (nnimap-send-command
+ "UID COPY %s %S"
+ (nnimap-article-ranges ranges)
+ (utf7-encode group t))
+ ranges)
+ sequences))))
;; Wait for the last COPY response...
(when sequences
(nnimap-wait-for-response (caar sequences))
;; And then mark the successful copy actions as deleted,
;; and possibly expunge them.
(nnimap-mark-and-expunge-incoming
- (nnimap-parse-copied-articles sequences)))))))))
+ (nnimap-parse-copied-articles sequences))
+ (nnimap-mark-and-expunge-incoming junk-articles))))))))
(defun nnimap-mark-and-expunge-incoming (range)
(when range
@@ -1125,7 +1154,7 @@ textual parts.")
(setq sequence (nnimap-send-command "UID EXPUNGE %s" range)))
;; If it doesn't support UID EXPUNGE, then we only expunge if the
;; user has configured it.
- (nnimap-expunge-inbox
+ (nnimap-expunge
(setq sequence (nnimap-send-command "EXPUNGE"))))
(nnimap-wait-for-response sequence))))
@@ -1142,8 +1171,8 @@ textual parts.")
(let (new)
(dolist (elem flags)
(when (or (null (cdr elem))
- (and (not (member "\\Deleted" (cdr elem)))
- (not (member "\\Seen" (cdr elem)))))
+ (and (not (memq '%Deleted (cdr elem)))
+ (not (memq '%Seen (cdr elem)))))
(push (car elem) new)))
(gnus-compress-sequence (nreverse new))))
@@ -1190,7 +1219,10 @@ textual parts.")
(if (not (re-search-forward "X-nnimap-article: \\([0-9]+\\)" nil t))
(error "Invalid nnimap mail")
(setq article (string-to-number (match-string 1))))
- (push (list article group-art)
+ (push (list article
+ (if (eq group-art 'junk)
+ (list (cons 'junk 1))
+ group-art))
nnimap-incoming-split-list)))
(provide 'nnimap)
diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el
index 95a98352f00..731d85b53ca 100644
--- a/lisp/gnus/nnmail.el
+++ b/lisp/gnus/nnmail.el
@@ -963,7 +963,7 @@ If SOURCE is a directory spec, try to return the group name component."
(goto-char end)))
count))
-(defun nnmail-process-mmdf-mail-format (func artnum-func)
+(defun nnmail-process-mmdf-mail-format (func artnum-func &optional junk-func)
(let ((delim "^\^A\^A\^A\^A$")
(case-fold-search t)
(count 0)
@@ -1011,7 +1011,7 @@ If SOURCE is a directory spec, try to return the group name component."
(narrow-to-region start (point))
(goto-char (point-min))
(incf count)
- (nnmail-check-duplication message-id func artnum-func)
+ (nnmail-check-duplication message-id func artnum-func junk-func)
(setq end (point-max))))
(goto-char end)
(forward-line 2)))
@@ -1056,7 +1056,7 @@ If SOURCE is a directory spec, try to return the group name component."
"Non-nil means group names are not encoded.")
(defun nnmail-split-incoming (incoming func &optional exit-func
- group artnum-func)
+ group artnum-func junk-func)
"Go through the entire INCOMING file and pick out each individual mail.
FUNC will be called with the buffer narrowed to each mail.
INCOMING can also be a buffer object. In that case, the mail
@@ -1087,7 +1087,8 @@ will be copied over from that buffer."
(looking-at "BABYL OPTIONS:"))
(nnmail-process-babyl-mail-format func artnum-func))
((looking-at "\^A\^A\^A\^A")
- (nnmail-process-mmdf-mail-format func artnum-func))
+ (nnmail-process-mmdf-mail-format
+ func artnum-func junk-func))
((looking-at "Return-Path:")
(nnmail-process-maildir-mail-format func artnum-func))
(t
@@ -1096,7 +1097,7 @@ will be copied over from that buffer."
(funcall exit-func))
(kill-buffer (current-buffer))))))
-(defun nnmail-article-group (func &optional trace)
+(defun nnmail-article-group (func &optional trace junk-func)
"Look at the headers and return an alist of groups that match.
FUNC will be called with the group name to determine the article number."
(let ((methods (or nnmail-split-methods '(("bogus" ""))))
@@ -1163,9 +1164,10 @@ FUNC will be called with the group name to determine the article number."
;; The article may be "cross-posted" to `junk'. What
;; to do? Just remove the `junk' spec. Don't really
;; see anything else to do...
- (let (elem)
- (while (setq elem (car (memq 'junk split)))
- (setq split (delq elem split))))
+ (when (and (memq 'junk split)
+ junk-func)
+ (funcall junk-func 'junk))
+ (setq split (delq 'junk split))
(when split
(setq group-art
(mapcar
@@ -1714,7 +1716,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(message-narrow-to-head)
(message-fetch-field header))))
-(defun nnmail-check-duplication (message-id func artnum-func)
+(defun nnmail-check-duplication (message-id func artnum-func
+ &optional junk-func)
(run-hooks 'nnmail-prepare-incoming-message-hook)
;; If this is a duplicate message, then we do not save it.
(let* ((duplication (nnmail-cache-id-exists-p message-id))
@@ -1739,7 +1742,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(cond
((not duplication)
(funcall func (setq group-art
- (nreverse (nnmail-article-group artnum-func))))
+ (nreverse (nnmail-article-group
+ artnum-func nil junk-func))))
(nnmail-cache-insert message-id (caar group-art)))
((eq action 'delete)
(setq group-art nil))
View Lorry Controller Status