aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorGnus developers2010-09-23 00:30:37 +0000
committerKatsumi Yamaoka2010-09-23 00:30:37 +0000
commitb069e5a697f37a06704136a8d5376b4d088658c8 (patch)
tree53d0985443df56d9ce2eaac82606489ccc77fa00
parent0521215472c696b55c8c372108e6555e3ec55c96 (diff)
downloademacs-b069e5a697f37a06704136a8d5376b4d088658c8.tar.gz
emacs-b069e5a697f37a06704136a8d5376b4d088658c8.zip
Merge Changes made in Gnus trunk.
gnus-html.el (gnus-html-get-image-data): Search also for \r\n\r\n to get the start of data. gnus-html.el: Use gnus-html-encode-url to encode URL. gnus-sum.el (gnus-update-marks): Add sanity check to not delete marks outside the active range. gnus.el: Try to keep the server/method cache unique. gnus-html.el (gnus-html-rescale-image): Use window-inside-pixel-edges rather than window-pixel-edges. gnus-html.el (gnus-html-put-image): Stop using markers. gnus-html.el (gnus-html-image-fetched): Search also for \r\n\r\n to get the start of data. nnimap.el: Expunge IMAP groups by default on article deletion. gnus-int.el (gnus-request-expire-articles): Inhibit the daemon, since this command might take a while. nnimap.el (nnimap-request-list): Set the current nnimap group to nil, since EXAMINE changes it on the server. nnmail.el, nnimap.el: Allow nnimap to just delete 'junk messages when splitting. nnimap.el (nnimap-parse-flags): Make IMAP flags parsing much faster by using `read'. nnimap.el (nnimap-make-process-buffer): Record the server name. gnus-html.el (gnus-html-image-fetched): Only cache if gnus-html-image-automatic-caching is set. gnus-html.el (gnus-html-image-fetched): Check for errors. gnus-start.el (gnus-read-active-for-groups): Only run -request-scan once per method on `g'. nnimap.el (nnimap-request-expire-articles): If nnmail-expiry-wait is immediate, then expire all articles. gnus-group.el (gnus-group-get-icon): Compute icon to return. gnus-group.el (gnus-group-icon-list): Fix bad docstring information. nnimap.el (nnimap-update-info): Fix up various off-by-one errors when syncing flags in nnimap. time-date.el (date-to-time): Speed up date-to-time. gnus-start.el (gnus-get-unread-articles): Don't have `gnus-get-unread-articles-in-group' update info. gnus-group.el: Remove gnus-group-highlight-line from the default hook list. gnus-group.el (gnus-group-highlight-line): Typo fix: beg, not start. gnus-group.el (gnus-group-insert-group-line): Pass the real group name so that it gets the right data. gnus-int.el (gnus-open-server): Add tracing for performance debugging. nnimap.el (nnimap-parse-flags): Parse the data in any order. nnimap.el (nnimap-update-info): Fix up code slightly.
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.
1996@vindex gnus-group-update-hook 1996@vindex gnus-group-update-hook
1997@findex gnus-group-highlight-line 1997@findex gnus-group-highlight-line
1998@code{gnus-group-update-hook} is called when a group line is changed. 1998@code{gnus-group-update-hook} is called when a group line is changed.
1999It will not be called when @code{gnus-visual} is @code{nil}. This hook 1999It will not be called when @code{gnus-visual} is @code{nil}.
2000calls @code{gnus-group-highlight-line} by default.
2001 2000
2002 2001
2003@node Group Maneuvering 2002@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 @@
12010-09-22 Dan Christensen <jdc@uwo.ca>
2
3 * calendar/time-date.el (date-to-time): Try using parse-time-string
4 first before using the slower timezone-make-date-arpa-standard.
5
12010-09-22 Katsumi Yamaoka <yamaoka@jpl.org> 62010-09-22 Katsumi Yamaoka <yamaoka@jpl.org>
2 7
3 * calendar/time-date.el (format-seconds): Comment fix. 8 * 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)."
97(autoload 'timezone-make-date-arpa-standard "timezone") 97(autoload 'timezone-make-date-arpa-standard "timezone")
98 98
99;;;###autoload 99;;;###autoload
100;; `parse-time-string' isn't sufficiently general or robust. It fails
101;; to grok some of the formats that timezone does (e.g. dodgy
102;; post-2000 stuff from some Elms) and either fails or returns bogus
103;; values. timezone-make-date-arpa-standard should help.
100(defun date-to-time (date) 104(defun date-to-time (date)
101 "Parse a string DATE that represents a date-time and return a time value. 105 "Parse a string DATE that represents a date-time and return a time value.
102If DATE lacks timezone information, GMT is assumed." 106If DATE lacks timezone information, GMT is assumed."
103 (condition-case () 107 (condition-case ()
104 (apply 'encode-time 108 (apply 'encode-time (parse-time-string date))
105 (parse-time-string 109 (error (condition-case ()
106 ;; `parse-time-string' isn't sufficiently general or 110 (apply 'encode-time
107 ;; robust. It fails to grok some of the formats that 111 (parse-time-string
108 ;; timezone does (e.g. dodgy post-2000 stuff from some 112 (timezone-make-date-arpa-standard date)))
109 ;; Elms) and either fails or returns bogus values. Lars 113 (error (error "Invalid date: %s" date))))))
110 ;; reverted this change, but that loses non-trivially
111 ;; often for me. -- fx
112 (timezone-make-date-arpa-standard date)))
113 (error (error "Invalid date: %s" date))))
114 114
115;; Bit of a mess. Emacs has float-time since at least 21.1. 115;; Bit of a mess. Emacs has float-time since at least 21.1.
116;; This file is synced to Gnus, and XEmacs packages may have been written 116;; 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 @@
12010-09-22 Lars Magne Ingebrigtsen <larsi@gnus.org>
2
3 * nnimap.el (nnimap-parse-flags): Parse the data in any order.
4 (nnimap-update-info): Fix up code slightly.
5
6 * gnus-int.el (gnus-open-server): Add tracing for performance
7 debugging.
8
9 * gnus-group.el (gnus-group-highlight-line): Typo fix: beg, not start.
10 (gnus-group-insert-group-line): Pass the real group name so that it
11 gets the right data.
12
13 * gnus-start.el (gnus-get-unread-articles): Don't have
14 `gnus-get-unread-articles-in-group' update info, since that can be
15 really slow and doesn't seem to be needed?
16
172010-09-22 Dan Christensen <jdc@uwo.ca>
18
19 * time-date.el (date-to-time): Try using parse-time-string first before
20 using the slower timezone-make-date-arpa-standard.
21
222010-09-22 Julien Danjou <julien@danjou.info>
23
24 * gnus-group.el (gnus-group-insert-group-line): Call
25 gnus-group-highlight-line.
26 (gnus-group-update-hook): Remove gnus-group-highlight-line from the
27 default hook list.
28 (gnus-group-update-eval-form): Add new function.
29 (gnus-group-highlight-line): Use gnus-group-update-eval-form.
30 (gnus-group-get-icon): Use gnus-group-update-eval-form.
31
322010-09-22 Lars Magne Ingebrigtsen <larsi@gnus.org>
33
34 * nnimap.el (nnimap-request-expire-articles): If nnmail-expiry-wait is
35 immediate, then expire all articles.
36 (nnimap-update-info): Fix off-by-one errors.
37 (nnimap-flags-to-marks): Would return no marks lists for group with no
38 flags. Instead return the other data.
39
402010-09-22 Julien Danjou <julien@danjou.info>
41
42 * gnus-group.el (gnus-group-get-icon): Renamed gnus-group-add-icon that
43 Only return an icon.
44 (gnus-group-insert-group-line): Compute icon to return.
45
46 * gnus-html.el (gnus-html-image-automatic-caching): Add custom
47 variable.
48 (gnus-html-image-fetched): Only cache if
49 gnus-html-image-automatic-caching is set.
50 (gnus-html-image-fetched): Check for errors.
51
522010-09-22 Lars Magne Ingebrigtsen <larsi@gnus.org>
53
54 * gnus-start.el (gnus-read-active-for-groups): Only run -request-scan
55 once per method on `g'. This ensures that backends like nnfolder don't
56 open all their folders.
57
58 * nnimap.el (nnimap-split-incoming-mail): Delete 'junk.
59 (nnimap-request-list): Nix out group in the correct buffer.
60 (nnimap-parse-flags): Implement by using `read' instead of
61 hand-parsing.
62 (nnimap-flags-to-marks): Pass on permanent-flags.
63 (nnimap-make-process-buffer): Record the server name.
64 (nnimap-parse-flags): Fix typo.
65 (nnimap-request-scan): Run split on the server in general, not just a
66 single group.
67
68 * nnmail.el (nnmail-split-incoming): Take an optional junk-func
69 parameter, and propagate this downwards.
70
71 * nnimap.el (nnimap-request-list): Set the current nnimap group to nil,
72 since EXAMINE changes it on the server.
73
74 * gnus-int.el (gnus-request-expire-articles): Inhibit the daemon, since
75 this command might take a while.
76
772010-09-22 Julien Danjou <julien@danjou.info>
78
79 * gnus-html.el (gnus-html-rescale-image): Use window-inside-pixel-edges
80 rather than window-pixel-edges.
81 (gnus-html-put-image): Stop using markers. They are harmful if you have
82 2 images side-by-side, they can't be properly update on text deletion.
83 Using text-property is safer here.
84 (gnus-html-image-fetched): Search also for \r\n\r\n to get the start of
85 data.
86
872010-09-22 Lars Magne Ingebrigtsen <larsi@gnus.org>
88
89 * nnimap.el (nnimap-expunge-inbox): Removed.
90 (nnimap-mark-and-expunge-incoming): Use nnimap-expunge instead.
91 (nnimap-expunge): Flip default to t.
92
93 * gnus.el (gnus-method-to-server): Don't push things to the cache
94 unless it's unique.
95 (gnus-server-to-method): Ditto.
96
12010-09-22 Teodor Zlatanov <tzz@lifelogs.com> 972010-09-22 Teodor Zlatanov <tzz@lifelogs.com>
2 98
3 * nnimap.el (nnimap-delete-article): Tell user if expunge won't happen. 99 * nnimap.el (nnimap-delete-article): Tell user if expunge won't happen.
4 100
52010-09-22 Julien Danjou <julien@danjou.info> 1012010-09-22 Julien Danjou <julien@danjou.info>
6 102
103 * gnus-html.el (gnus-html-get-image-data): Search also for \r\n\r\n to
104 get the start of data.
105 (gnus-html-encode-url): Add this function to encode special chars in
106 URL.
107 (gnus-html-wash-images): Use gnus-html-encode-url to encode URL.
108 (gnus-html-prefetch-images): Use gnus-html-encode-url to encode URL.
109
7 * gnus-group.el (gnus-group-update-hook): Call gnus-group-add-icon by 110 * gnus-group.el (gnus-group-update-hook): Call gnus-group-add-icon by
8 default. 111 default.
9 (gnus-group-add-icon): Move to gnus-group.el, and rewrite so it works. 112 (gnus-group-add-icon): Move to gnus-group.el, and rewrite so it works.
@@ -19,6 +122,19 @@
19 * nnir.el (nnir-run-find-grep) 122 * nnir.el (nnir-run-find-grep)
20 * pop3.el (pop3-list): Use 3rd arg of split-string. 123 * pop3.el (pop3-list): Use 3rd arg of split-string.
21 124
1252010-09-21 Lars Magne Ingebrigtsen <larsi@gnus.org>
126
127 * gnus-sum.el (gnus-update-marks): Add sanity check to not delete marks
128 outside the active range. Suggested by Dan Christensen.
129
130 * gnus-start.el (gnus-get-unread-articles): Get the extended method
131 slightly later to avoid double-getting it.
132
133 * nnml.el (nnml-generate-nov-file): Fix variable name clobbering from
134 previous patch.
135
136 * gnus-sum.el (gnus-adjust-marked-articles): Fix another typo.
137
222010-09-21 Adam Sjøgren <asjo@koldfront.dk> 1382010-09-21 Adam Sjøgren <asjo@koldfront.dk>
23 139
24 * gnus-sum.el (gnus-adjust-marked-articles): Fix typo. 140 * gnus-sum.el (gnus-adjust-marked-articles): Fix typo.
@@ -103,6 +219,9 @@
103 219
1042010-09-20 Lars Magne Ingebrigtsen <larsi@gnus.org> 2202010-09-20 Lars Magne Ingebrigtsen <larsi@gnus.org>
105 221
222 * gnus-group.el (gnus-group-line-format-alist): Have the ?U (unseen)
223 spec inser "*" if the group isn't active instead of 0.
224
106 * nnimap.el (nnimap-request-group): Don't select the imap buffer before 225 * nnimap.el (nnimap-request-group): Don't select the imap buffer before
107 opening the server. 226 opening the server.
108 (nnimap-request-delete-group): Implement group deletion. 227 (nnimap-request-delete-group): Implement group deletion.
@@ -369,7 +488,7 @@
369 488
370 * dgnushack.el: Define netrc-credentials. 489 * dgnushack.el: Define netrc-credentials.
371 490
3722010-09-17 Julien Danjou <julien@danjou.info> (tiny fix) 4912010-09-17 Julien Danjou <julien@danjou.info>
373 492
374 * mm-decode.el (mm-text-html-renderer): Document gnus-article-html. 493 * mm-decode.el (mm-text-html-renderer): Document gnus-article-html.
375 494
@@ -439,6 +558,9 @@
439 558
4402010-09-14 Lars Magne Ingebrigtsen <larsi@gnus.org> 5592010-09-14 Lars Magne Ingebrigtsen <larsi@gnus.org>
441 560
561 * gnus-registry.el (gnus-registry-install-shortcuts): The second
562 parameter to unintern is mandatory-ish in Emacs 24.
563
442 * gnus-html.el (gnus-html-schedule-image-fetching) 564 * gnus-html.el (gnus-html-schedule-image-fetching)
443 (gnus-html-prefetch-images): Check for curl before using it. 565 (gnus-html-prefetch-images): Check for curl before using it.
444 566
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."
292 :group 'gnus-exit 292 :group 'gnus-exit
293 :type 'hook) 293 :type 'hook)
294 294
295(defcustom gnus-group-update-hook '(gnus-group-highlight-line gnus-group-add-icon) 295(defcustom gnus-group-update-hook nil
296 "Hook called when a group line is changed. 296 "Hook called when a group line is changed."
297The hook will not be called if `gnus-visual' is nil.
298
299The default functions `gnus-group-highlight-line' will highlight
300the line according to the `gnus-group-highlight' variable, and
301`gnus-group-add-icon' will add an icon according to
302`gnus-group-icon-list'"
303 :group 'gnus-group-visual 297 :group 'gnus-group-visual
304 :type 'hook) 298 :type 'hook)
305 299
@@ -429,7 +423,6 @@ group: The name of the group.
429unread: The number of unread articles in the group. 423unread: The number of unread articles in the group.
430method: The select method used. 424method: The select method used.
431mailp: Whether it's a mail group or not. 425mailp: Whether it's a mail group or not.
432newsp: Whether it's a news group or not
433level: The level of the group. 426level: The level of the group.
434score: The score of the group. 427score: The score of the group.
435ticked: The number of ticked articles." 428ticked: The number of ticked articles."
@@ -1579,7 +1572,7 @@ if it is a string, only list groups matching REGEXP."
1579 ?m ? )) 1572 ?m ? ))
1580 (gnus-tmp-moderated-string 1573 (gnus-tmp-moderated-string
1581 (if (eq gnus-tmp-moderated ?m) "(m)" "")) 1574 (if (eq gnus-tmp-moderated ?m) "(m)" ""))
1582 (gnus-tmp-group-icon (propertize " " 'gnus-group-icon t)) 1575 (gnus-tmp-group-icon (gnus-group-get-icon gnus-tmp-qualified-group))
1583 (gnus-tmp-news-server (or (cadr gnus-tmp-method) "")) 1576 (gnus-tmp-news-server (or (cadr gnus-tmp-method) ""))
1584 (gnus-tmp-news-method (or (car gnus-tmp-method) "")) 1577 (gnus-tmp-news-method (or (car gnus-tmp-method) ""))
1585 (gnus-tmp-news-method-string 1578 (gnus-tmp-news-method-string
@@ -1626,108 +1619,85 @@ if it is a string, only list groups matching REGEXP."
1626 'gnus-tool-bar-update)) 1619 'gnus-tool-bar-update))
1627 (forward-line -1) 1620 (forward-line -1)
1628 (when (inline (gnus-visual-p 'group-highlight 'highlight)) 1621 (when (inline (gnus-visual-p 'group-highlight 'highlight))
1629 (gnus-run-hooks 'gnus-group-update-hook)) 1622 (gnus-group-highlight-line gnus-tmp-group beg end))
1623 (gnus-run-hooks 'gnus-group-update-hook)
1630 (forward-line) 1624 (forward-line)
1631 ;; Allow XEmacs to remove front-sticky text properties. 1625 ;; Allow XEmacs to remove front-sticky text properties.
1632 (gnus-group-remove-excess-properties))) 1626 (gnus-group-remove-excess-properties)))
1633 1627
1634(defun gnus-group-highlight-line () 1628(defun gnus-group-update-eval-form (group list)
1635 "Highlight the current line according to `gnus-group-highlight'." 1629 "Eval `car' of each element of LIST, and return the first that return t.
1636 (let* ((list gnus-group-highlight) 1630Some value are bound so the form can use them."
1637 (p (point)) 1631 (when list
1638 (end (point-at-eol)) 1632 (let* ((entry (gnus-group-entry group))
1639 ;; now find out where the line starts and leave point there. 1633 (unread (if (numberp (car entry)) (car entry) 0))
1640 (beg (progn (beginning-of-line) (point))) 1634 (active (gnus-active group))
1641 (group (gnus-group-group-name)) 1635 (total (if active (1+ (- (cdr active) (car active))) 0))
1642 (entry (gnus-group-entry group)) 1636 (info (nth 2 entry))
1643 (unread (if (numberp (car entry)) (car entry) 0)) 1637 (method (inline (gnus-server-get-method group (gnus-info-method info))))
1644 (active (gnus-active group)) 1638 (marked (gnus-info-marks info))
1645 (total (if active (1+ (- (cdr active) (car active))) 0)) 1639 (mailp (apply 'append
1646 (info (nth 2 entry)) 1640 (mapcar
1647 (method (inline (gnus-server-get-method group (gnus-info-method info)))) 1641 (lambda (x)
1648 (marked (gnus-info-marks info)) 1642 (memq x (assoc (symbol-name
1649 (mailp (apply 'append 1643 (car (or method gnus-select-method)))
1650 (mapcar 1644 gnus-valid-select-methods)))
1651 (lambda (x) 1645 '(mail post-mail))))
1652 (memq x (assoc (symbol-name 1646 (level (or (gnus-info-level info) gnus-level-killed))
1653 (car (or method gnus-select-method))) 1647 (score (or (gnus-info-score info) 0))
1654 gnus-valid-select-methods))) 1648 (ticked (gnus-range-length (cdr (assq 'tick marked))))
1655 '(mail post-mail)))) 1649 (group-age (gnus-group-timestamp-delta group)))
1656 (level (or (gnus-info-level info) gnus-level-killed)) 1650 ;; FIXME: http://thread.gmane.org/gmane.emacs.gnus.general/65451/focus=65465
1657 (score (or (gnus-info-score info) 0)) 1651 ;; ======================================================================
1658 (ticked (gnus-range-length (cdr (assq 'tick marked)))) 1652 ;; From: Richard Stallman
1659 (group-age (gnus-group-timestamp-delta group)) 1653 ;; Subject: Re: Rewriting gnus-group-highlight-line (was: [...])
1660 (inhibit-read-only t)) 1654 ;; Cc: ding@gnus.org
1661 ;; FIXME: http://thread.gmane.org/gmane.emacs.gnus.general/65451/focus=65465 1655 ;; Date: Sat, 27 Oct 2007 19:41:20 -0400
1662 ;; ====================================================================== 1656 ;; Message-ID: <E1IlvHM-0006TS-7t@fencepost.gnu.org>
1663 ;; From: Richard Stallman 1657 ;;
1664 ;; Subject: Re: Rewriting gnus-group-highlight-line (was: [...]) 1658 ;; [...]
1665 ;; Cc: ding@gnus.org 1659 ;; The kludge is that the alist elements contain expressions that refer
1666 ;; Date: Sat, 27 Oct 2007 19:41:20 -0400 1660 ;; to local variables with short names. Perhaps write your own tiny
1667 ;; Message-ID: <E1IlvHM-0006TS-7t@fencepost.gnu.org> 1661 ;; evaluator that handles just `and', `or', and numeric comparisons
1668 ;; 1662 ;; and just a few specific variables.
1669 ;; [...] 1663 ;; ======================================================================
1670 ;; The kludge is that the alist elements contain expressions that refer 1664 ;;
1671 ;; to local variables with short names. Perhaps write your own tiny 1665 ;; Similar for other evaluated variables. Grep for risky-local-variable
1672 ;; evaluator that handles just `and', `or', and numeric comparisons 1666 ;; to find them! -- rsteib
1673 ;; and just a few specific variables. 1667 ;;
1674 ;; ====================================================================== 1668 ;; Eval the cars of the lists until we find a match.
1675 ;; 1669 (while (and list
1676 ;; Similar for other evaluated variables. Grep for risky-local-variable 1670 (not (eval (caar list))))
1677 ;; to find them! -- rsteib 1671 (setq list (cdr list)))
1678 ;; 1672 list)))
1679 ;; Eval the cars of the lists until we find a match. 1673
1680 (while (and list 1674(defun gnus-group-highlight-line (group beg end)
1681 (not (eval (caar list)))) 1675 "Highlight the current line according to `gnus-group-highlight'.
1682 (setq list (cdr list))) 1676GROUP is current group, and the line to highlight starts at START
1683 (let ((face (cdar list))) 1677and ends at END."
1684 (unless (eq face (get-text-property beg 'face)) 1678 (let ((face (cdar (gnus-group-update-eval-form
1685 (gnus-put-text-property-excluding-characters-with-faces 1679 group
1686 beg end 'face 1680 gnus-group-highlight))))
1687 (setq face (if (boundp face) (symbol-value face) face))) 1681 (unless (eq face (get-text-property beg 'face))
1688 (gnus-extent-start-open beg))) 1682 (let ((inhibit-read-only t))
1689 (goto-char p))) 1683 (gnus-put-text-property-excluding-characters-with-faces
1690 1684 beg end 'face
1691(defun gnus-group-add-icon () 1685 (if (boundp face) (symbol-value face) face)))
1692 "Add an icon to the current line according to `gnus-group-icon-list'." 1686 (gnus-extent-start-open beg))))
1693 (save-excursion 1687
1694 (let* ((end (line-end-position)) 1688(defun gnus-group-get-icon (group)
1695 ;; now find out where the line starts and leave point there. 1689 "Return an icon for GROUP according to `gnus-group-icon-list'."
1696 (beg (line-beginning-position))) 1690 (if gnus-group-icon-list
1697 (save-restriction 1691 (let ((image-path
1698 (narrow-to-region beg end) 1692 (cdar (gnus-group-update-eval-form group gnus-group-icon-list))))
1699 (goto-char beg) 1693 (if image-path
1700 (let ((mystart (text-property-any beg end 'gnus-group-icon t))) 1694 (propertize " "
1701 (when mystart 1695 'display
1702 (let* ((group (gnus-group-group-name)) 1696 (append
1703 (entry (gnus-group-entry group)) 1697 (gnus-create-image (expand-file-name image-path))
1704 (unread (if (numberp (car entry)) (car entry) 0)) 1698 '(:ascent center)))
1705 (active (gnus-active group)) 1699 " "))
1706 (total (if active (1+ (- (cdr active) (car active))) 0)) 1700 " "))
1707 (info (nth 2 entry))
1708 (method (gnus-server-get-method group (gnus-info-method info)))
1709 (marked (gnus-info-marks info))
1710 (mailp (memq 'mail (assoc (symbol-name
1711 (car (or method gnus-select-method)))
1712 gnus-valid-select-methods)))
1713 (level (or (gnus-info-level info) gnus-level-killed))
1714 (score (or (gnus-info-score info) 0))
1715 (ticked (gnus-range-length (cdr (assq 'tick marked))))
1716 (group-age (gnus-group-timestamp-delta group))
1717 (inhibit-read-only t)
1718 (list gnus-group-icon-list)
1719 (myend (next-single-property-change
1720 mystart 'gnus-group-icon)))
1721 (while (and list
1722 (not (eval (caar list))))
1723 (setq list (cdr list)))
1724 (when list
1725 (put-text-property
1726 mystart myend
1727 'display
1728 (append
1729 (gnus-create-image (expand-file-name (cdar list)))
1730 '(:ascent center)))))))))))
1731 1701
1732(defun gnus-group-update-group (group &optional visible-only) 1702(defun gnus-group-update-group (group &optional visible-only)
1733 "Update all lines where GROUP appear. 1703 "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 @@
36(require 'url) 36(require 'url)
37(require 'url-cache) 37(require 'url-cache)
38(require 'xml) 38(require 'xml)
39(require 'browse-url)
39 40
40(defcustom gnus-html-image-cache-ttl (days-to-time 7) 41(defcustom gnus-html-image-cache-ttl (days-to-time 7)
41 "Time in seconds used to cache the image on disk." 42 "Time used to determine if we should use images from the cache."
42 :version "24.1" 43 :version "24.1"
43 :group 'gnus-art 44 :group 'gnus-art
44 :type 'integer) 45 :type 'integer)
45 46
47(defcustom gnus-html-image-automatic-caching t
48 "Whether automatically cache retrieve images."
49 :version "24.1"
50 :group 'gnus-art
51 :type 'boolean)
52
46(defcustom gnus-html-frame-width 70 53(defcustom gnus-html-frame-width 70
47 "What width to use when rendering HTML." 54 "What width to use when rendering HTML."
48 :version "24.1" 55 :version "24.1"
@@ -81,6 +88,10 @@ fit these criteria."
81 (define-key map [tab] 'widget-forward) 88 (define-key map [tab] 'widget-forward)
82 map)) 89 map))
83 90
91(defun gnus-html-encode-url (url)
92 "Encode URL."
93 (browse-url-url-encode-chars url "[)$ ]"))
94
84(defun gnus-html-cache-expired (url ttl) 95(defun gnus-html-cache-expired (url ttl)
85 "Check if URL is cached for more than TTL." 96 "Check if URL is cached for more than TTL."
86 (cond (url-standalone-mode 97 (cond (url-standalone-mode
@@ -155,7 +166,7 @@ fit these criteria."
155 (delete-region (match-beginning 0) (match-end 0))) 166 (delete-region (match-beginning 0) (match-end 0)))
156 (setq end (point)) 167 (setq end (point))
157 (when (string-match "src=\"\\([^\"]+\\)" parameters) 168 (when (string-match "src=\"\\([^\"]+\\)" parameters)
158 (setq url (match-string 1 parameters)) 169 (setq url (gnus-html-encode-url (match-string 1 parameters)))
159 (gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url) 170 (gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url)
160 (if (string-match "^cid:\\(.*\\)" url) 171 (if (string-match "^cid:\\(.*\\)" url)
161 ;; URLs with cid: have their content stashed in other 172 ;; URLs with cid: have their content stashed in other
@@ -177,6 +188,7 @@ fit these criteria."
177 (let ((alt-text (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)" 188 (let ((alt-text (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)"
178 parameters) 189 parameters)
179 (xml-substitute-special (match-string 2 parameters))))) 190 (xml-substitute-special (match-string 2 parameters)))))
191 (gnus-put-text-property start end 'gnus-image-url url)
180 (if (gnus-html-image-url-blocked-p 192 (if (gnus-html-image-url-blocked-p
181 url 193 url
182 (if (buffer-live-p gnus-summary-buffer) 194 (if (buffer-live-p gnus-summary-buffer)
@@ -191,13 +203,9 @@ fit these criteria."
191 :keymap gnus-html-image-map 203 :keymap gnus-html-image-map
192 :button-keymap gnus-html-image-map) 204 :button-keymap gnus-html-image-map)
193 (let ((overlay (gnus-make-overlay start end)) 205 (let ((overlay (gnus-make-overlay start end))
194 (spec (list url 206 (spec (list url alt-text)))
195 (set-marker (make-marker) start)
196 (set-marker (make-marker) end)
197 alt-text)))
198 (gnus-overlay-put overlay 'local-map gnus-html-image-map) 207 (gnus-overlay-put overlay 'local-map gnus-html-image-map)
199 (gnus-overlay-put overlay 'gnus-image spec) 208 (gnus-overlay-put overlay 'gnus-image spec)
200 (gnus-put-text-property start end 'gnus-image-url url)
201 (gnus-put-text-property 209 (gnus-put-text-property
202 start end 210 start end
203 'gnus-image spec))) 211 'gnus-image spec)))
@@ -224,13 +232,9 @@ Use ALT-TEXT for the image string."
224 ;; asynchronously. 232 ;; asynchronously.
225 (gnus-html-schedule-image-fetching 233 (gnus-html-schedule-image-fetching
226 (current-buffer) 234 (current-buffer)
227 (list url 235 (list url alt-text))
228 (set-marker (make-marker) start)
229 (set-marker (make-marker) end)
230 alt-text))
231 ;; It's already cached, so just insert it. 236 ;; It's already cached, so just insert it.
232 (gnus-html-put-image (gnus-html-get-image-data url) 237 (gnus-html-put-image (gnus-html-get-image-data url) url alt-text)))
233 start end url alt-text)))
234 238
235(defun gnus-html-wash-tags () 239(defun gnus-html-wash-tags ()
236 (let (tag parameters string start end images url) 240 (let (tag parameters string start end images url)
@@ -347,22 +351,17 @@ Use ALT-TEXT for the image string."
347 (list buffer image)))) 351 (list buffer image))))
348 352
349(defun gnus-html-image-fetched (status buffer image) 353(defun gnus-html-image-fetched (status buffer image)
350 (url-store-in-cache (current-buffer)) 354 "Callback function called when image has been fetched."
351 (when (and (search-forward "\n\n" nil t) 355 (unless (plist-get status :error)
352 (buffer-live-p buffer) 356 (when gnus-html-image-automatic-caching
353 ;; If the `image' has no marker, do not replace anything 357 (url-store-in-cache (current-buffer)))
354 (cadr image) 358 (when (and (or (search-forward "\n\n" nil t)
355 ;; If the position of the marker is 1, then that 359 (search-forward "\r\n\r\n" nil t))
356 ;; means that the text it was in has been deleted; 360 (buffer-live-p buffer))
357 ;; i.e., that the user has selected a different 361 (let ((data (buffer-substring (point) (point-max))))
358 ;; article before the image arrived. 362 (with-current-buffer buffer
359 (not (= (marker-position (cadr image)) 363 (let ((inhibit-read-only t))
360 (with-current-buffer buffer 364 (gnus-html-put-image data (car image) (cadr image)))))))
361 (point-min)))))
362 (let ((data (buffer-substring (point) (point-max))))
363 (with-current-buffer buffer
364 (let ((inhibit-read-only t))
365 (gnus-html-put-image data (cadr image) (caddr image) (car image) (cadddr image))))))
366 (kill-buffer (current-buffer))) 365 (kill-buffer (current-buffer)))
367 366
368(defun gnus-html-get-image-data (url) 367(defun gnus-html-get-image-data (url)
@@ -371,54 +370,61 @@ Return a string with image data."
371 (with-temp-buffer 370 (with-temp-buffer
372 (mm-disable-multibyte) 371 (mm-disable-multibyte)
373 (url-cache-extract (url-cache-create-filename url)) 372 (url-cache-extract (url-cache-create-filename url))
374 (when (search-forward "\n\n" nil t) 373 (when (or (search-forward "\n\n" nil t)
374 (search-forward "\r\n\r\n" nil t))
375 (buffer-substring (point) (point-max))))) 375 (buffer-substring (point) (point-max)))))
376 376
377(defun gnus-html-put-image (data start end &optional url alt-text) 377(defun gnus-html-put-image (data url &optional alt-text)
378 (when (gnus-graphic-display-p) 378 (when (gnus-graphic-display-p)
379 (let* ((image (ignore-errors 379 (let* ((start (text-property-any (point-min) (point-max) 'gnus-image-url url))
380 (gnus-create-image data nil t))) 380 (end (when start
381 (size (and image 381 (next-single-property-change start 'gnus-image-url))))
382 (if (featurep 'xemacs) 382 ;; Image found?
383 (cons (glyph-width image) (glyph-height image)) 383 (when start
384 (image-size image t))))) 384 (let* ((image
385 (save-excursion 385 (ignore-errors
386 (goto-char start) 386 (gnus-create-image data nil t)))
387 (let ((alt-text (or alt-text (buffer-substring-no-properties start end)))) 387 (size (and image
388 (if (and image 388 (if (featurep 'xemacs)
389 ;; Kludge to avoid displaying 30x30 gif images, which 389 (cons (glyph-width image) (glyph-height image))
390 ;; seems to be a signal of a broken image. 390 (image-size image t)))))
391 (not (and (if (featurep 'xemacs) 391 (save-excursion
392 (glyphp image) 392 (goto-char start)
393 (listp image)) 393 (let ((alt-text (or alt-text (buffer-substring-no-properties start end))))
394 (eq (if (featurep 'xemacs) 394 (if (and image
395 (let ((d (cdadar (specifier-spec-list 395 ;; Kludge to avoid displaying 30x30 gif images, which
396 (glyph-image image))))) 396 ;; seems to be a signal of a broken image.
397 (and (vectorp d) 397 (not (and (if (featurep 'xemacs)
398 (aref d 0))) 398 (glyphp image)
399 (plist-get (cdr image) :type)) 399 (listp image))
400 'gif) 400 (eq (if (featurep 'xemacs)
401 (= (car size) 30) 401 (let ((d (cdadar (specifier-spec-list
402 (= (cdr size) 30)))) 402 (glyph-image image)))))
403 ;; Good image, add it! 403 (and (vectorp d)
404 (let ((image (gnus-html-rescale-image image data size))) 404 (aref d 0)))
405 (delete-region start end) 405 (plist-get (cdr image) :type))
406 (gnus-put-image image alt-text 'external) 406 'gif)
407 (gnus-put-text-property start (point) 'help-echo alt-text) 407 (= (car size) 30)
408 (gnus-overlay-put (gnus-make-overlay start (point)) 'local-map 408 (= (cdr size) 30))))
409 gnus-html-displayed-image-map) 409 ;; Good image, add it!
410 (gnus-put-text-property start (point) 'gnus-alt-text alt-text) 410 (let ((image (gnus-html-rescale-image image data size)))
411 (when url 411 (delete-region start end)
412 (gnus-put-text-property start (point) 'gnus-image-url url)) 412 (gnus-put-image image alt-text 'external)
413 (gnus-add-image 'external image) 413 (gnus-put-text-property start (point) 'help-echo alt-text)
414 t) 414 (gnus-overlay-put (gnus-make-overlay start (point)) 'local-map
415 ;; Bad image, try to show something else 415 gnus-html-displayed-image-map)
416 (delete-region start end) 416 (gnus-put-text-property start (point) 'gnus-alt-text alt-text)
417 (when (fboundp 'find-image) 417 (when url
418 (setq image (find-image '((:type xpm :file "lock-broken.xpm")))) 418 (gnus-put-text-property start (point) 'gnus-image-url url))
419 (gnus-put-image image alt-text 'internal) 419 (gnus-add-image 'external image)
420 (gnus-add-image 'internal image)) 420 t)
421 nil)))))) 421 ;; Bad image, try to show something else
422 (when (fboundp 'find-image)
423 (delete-region start end)
424 (setq image (find-image '((:type xpm :file "lock-broken.xpm"))))
425 (gnus-put-image image alt-text 'internal)
426 (gnus-add-image 'internal image))
427 nil))))))))
422 428
423(defun gnus-html-rescale-image (image data size) 429(defun gnus-html-rescale-image (image data size)
424 (if (or (not (fboundp 'imagemagick-types)) 430 (if (or (not (fboundp 'imagemagick-types))
@@ -426,7 +432,7 @@ Return a string with image data."
426 image 432 image
427 (let* ((width (car size)) 433 (let* ((width (car size))
428 (height (cdr size)) 434 (height (cdr size))
429 (edges (window-pixel-edges (get-buffer-window (current-buffer)))) 435 (edges (window-inside-pixel-edges (get-buffer-window (current-buffer))))
430 (window-width (truncate (* gnus-max-image-proportion 436 (window-width (truncate (* gnus-max-image-proportion
431 (- (nth 2 edges) (nth 0 edges))))) 437 (- (nth 2 edges) (nth 0 edges)))))
432 (window-height (truncate (* gnus-max-image-proportion 438 (window-height (truncate (* gnus-max-image-proportion
@@ -472,7 +478,7 @@ This only works if the article in question is HTML."
472 gnus-blocked-images))) 478 gnus-blocked-images)))
473 (save-match-data 479 (save-match-data
474 (while (re-search-forward "<img.*src=[\"']\\([^\"']+\\)" nil t) 480 (while (re-search-forward "<img.*src=[\"']\\([^\"']+\\)" nil t)
475 (let ((url (match-string 1))) 481 (let ((url (gnus-html-encode-url (match-string 1))))
476 (unless (gnus-html-image-url-blocked-p url blocked-images) 482 (unless (gnus-html-image-url-blocked-p url blocked-images)
477 (when (gnus-html-cache-expired url gnus-html-image-cache-ttl) 483 (when (gnus-html-cache-expired url gnus-html-image-cache-ttl)
478 (gnus-html-schedule-image-fetching nil 484 (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)."
226 (eq (nth 1 (assoc method gnus-opened-servers)) 226 (eq (nth 1 (assoc method gnus-opened-servers))
227 'denied)) 227 'denied))
228 228
229(defvar gnus-backend-trace t)
230
229(defun gnus-open-server (gnus-command-method) 231(defun gnus-open-server (gnus-command-method)
230 "Open a connection to GNUS-COMMAND-METHOD." 232 "Open a connection to GNUS-COMMAND-METHOD."
231 (when (stringp gnus-command-method) 233 (when (stringp gnus-command-method)
232 (setq gnus-command-method (gnus-server-to-method gnus-command-method))) 234 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
235 (when gnus-backend-trace
236 (with-current-buffer (get-buffer-create "*gnus trace*")
237 (buffer-disable-undo)
238 (goto-char (point-max))
239 (insert (format-time-string "%H:%M:%S")
240 (format " %S\n" gnus-command-method))))
233 (let ((elem (assoc gnus-command-method gnus-opened-servers)) 241 (let ((elem (assoc gnus-command-method gnus-opened-servers))
234 (server (gnus-method-to-server-name gnus-command-method))) 242 (server (gnus-method-to-server-name gnus-command-method)))
235 ;; If this method was previously denied, we just return nil. 243 ;; 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."
601 609
602(defun gnus-request-expire-articles (articles group &optional force) 610(defun gnus-request-expire-articles (articles group &optional force)
603 (let* ((gnus-command-method (gnus-find-method-for-group group)) 611 (let* ((gnus-command-method (gnus-find-method-for-group group))
612 (gnus-inhibit-demon t)
604 (not-deleted 613 (not-deleted
605 (funcall 614 (funcall
606 (gnus-get-function gnus-command-method 'request-expire-articles) 615 (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."
1757 (when (gnus-check-backend-function 1757 (when (gnus-check-backend-function
1758 'retrieve-group-data-early (car method)) 1758 'retrieve-group-data-early (car method))
1759 (when (gnus-check-backend-function 'request-scan (car method)) 1759 (when (gnus-check-backend-function 'request-scan (car method))
1760 (dolist (info infos) 1760 (gnus-request-scan nil method))
1761 (gnus-request-scan (gnus-info-group info) method)))
1762 (setcar (nthcdr 3 elem) 1761 (setcar (nthcdr 3 elem)
1763 (gnus-retrieve-group-data-early method infos)))))) 1762 (gnus-retrieve-group-data-early method infos))))))
1764 1763
@@ -1770,8 +1769,7 @@ If SCAN, request a scan of that group as well."
1770 (gnus-read-active-for-groups method infos early-data) 1769 (gnus-read-active-for-groups method infos early-data)
1771 (dolist (info infos) 1770 (dolist (info infos)
1772 (inline (gnus-get-unread-articles-in-group 1771 (inline (gnus-get-unread-articles-in-group
1773 info (gnus-active (gnus-info-group info)) 1772 info (gnus-active (gnus-info-group info))))))))
1774 t))))))
1775 (gnus-message 6 "Checking new news...done"))) 1773 (gnus-message 6 "Checking new news...done")))
1776 1774
1777(defun gnus-method-rank (type method) 1775(defun gnus-method-rank (type method)
@@ -1806,8 +1804,7 @@ If SCAN, request a scan of that group as well."
1806 (gnus-agent-save-active method)) 1804 (gnus-agent-save-active method))
1807 ((gnus-check-backend-function 'retrieve-groups (car method)) 1805 ((gnus-check-backend-function 'retrieve-groups (car method))
1808 (when (gnus-check-backend-function 'request-scan (car method)) 1806 (when (gnus-check-backend-function 'request-scan (car method))
1809 (dolist (info infos) 1807 (gnus-request-scan nil method))
1810 (gnus-request-scan (gnus-info-group info) method)))
1811 (let (groups) 1808 (let (groups)
1812 (gnus-read-active-file-2 1809 (gnus-read-active-file-2
1813 (dolist (info infos (nreverse groups)) 1810 (dolist (info infos (nreverse groups))
@@ -2055,10 +2052,7 @@ If SCAN, request a scan of that group as well."
2055 (gnus-online method)) 2052 (gnus-online method))
2056 (not gnus-agent)) 2053 (not gnus-agent))
2057 (gnus-check-backend-function 'request-scan (car method))) 2054 (gnus-check-backend-function 'request-scan (car method)))
2058 (if infos 2055 (gnus-request-scan nil method))
2059 (dolist (info infos)
2060 (gnus-request-scan (gnus-info-group info) method))
2061 (gnus-request-scan nil method)))
2062 (cond 2056 (cond
2063 ((and (eq gnus-read-active-file 'some) 2057 ((and (eq gnus-read-active-file 'some)
2064 (gnus-check-backend-function 'retrieve-groups (car method)) 2058 (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."
5976 (when add 5976 (when add
5977 (push (list add 'add (list (cdr type))) delta-marks)) 5977 (push (list add 'add (list (cdr type))) delta-marks))
5978 (when del 5978 (when del
5979 ;; Don't delete marks from outside the active range. This
5980 ;; shouldn't happen, but is a sanity check.
5981 (setq del (gnus-sorted-range-intersection
5982 (gnus-active gnus-newsgroup-name) del))
5979 (push (list del 'del (list (cdr type))) delta-marks)))) 5983 (push (list del 'del (list (cdr type))) delta-marks))))
5980 5984
5981 (when list 5985 (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."
3566 (nth 1 method)))) 3566 (nth 1 method))))
3567 method))) 3567 method)))
3568 3568
3569(defsubst gnus-method-to-server (method &optional nocache) 3569(defsubst gnus-method-to-server (method &optional nocache no-enter-cache)
3570 (catch 'server-name 3570 (catch 'server-name
3571 (setq method (or method gnus-select-method)) 3571 (setq method (or method gnus-select-method))
3572 3572
@@ -3592,7 +3592,9 @@ that that variable is buffer-local to the summary buffers."
3592 (format "%s" (car method)) 3592 (format "%s" (car method))
3593 (format "%s:%s" (car method) (cadr method)))) 3593 (format "%s:%s" (car method) (cadr method))))
3594 (name-method (cons name method))) 3594 (name-method (cons name method)))
3595 (unless (member name-method gnus-server-method-cache) 3595 (when (and (not (member name-method gnus-server-method-cache))
3596 (not no-enter-cache)
3597 (not (assoc (car name-method) gnus-server-method-cache)))
3596 (push name-method gnus-server-method-cache)) 3598 (push name-method gnus-server-method-cache))
3597 name))) 3599 name)))
3598 3600
@@ -3634,11 +3636,13 @@ that that variable is buffer-local to the summary buffers."
3634 (while alist 3636 (while alist
3635 (setq method (gnus-info-method (pop alist))) 3637 (setq method (gnus-info-method (pop alist)))
3636 (when (and (not (stringp method)) 3638 (when (and (not (stringp method))
3637 (equal server (gnus-method-to-server method))) 3639 (equal server
3640 (gnus-method-to-server method nil t)))
3638 (setq match method 3641 (setq match method
3639 alist nil))) 3642 alist nil)))
3640 match)))) 3643 match))))
3641 (when result 3644 (when (and result
3645 (not (assoc server gnus-server-method-cache)))
3642 (push (cons server result) gnus-server-method-cache)) 3646 (push (cons server result) gnus-server-method-cache))
3643 result))) 3647 result)))
3644 3648
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'.")
62(defvoo nnimap-inbox nil 62(defvoo nnimap-inbox nil
63 "The mail box where incoming mail arrives and should be split out of.") 63 "The mail box where incoming mail arrives and should be split out of.")
64 64
65(defvoo nnimap-expunge-inbox nil
66 "If non-nil, expunge the inbox after fetching mail.
67This is always done if the server supports UID EXPUNGE, but it's
68not done by default on servers that doesn't support that command.")
69
70(defvoo nnimap-authenticator nil 65(defvoo nnimap-authenticator nil
71 "How nnimap authenticate itself to the server. 66 "How nnimap authenticate itself to the server.
72Possible choices are nil (use default methods) or `anonymous'.") 67Possible choices are nil (use default methods) or `anonymous'.")
@@ -78,7 +73,11 @@ will fetch all parts that have types that match that string. A
78likely value would be \"text/\" to automatically fetch all 73likely value would be \"text/\" to automatically fetch all
79textual parts.") 74textual parts.")
80 75
81(defvoo nnimap-expunge nil) 76(defvoo nnimap-expunge t
77 "If non-nil, expunge articles after deleting them.
78This is always done if the server supports UID EXPUNGE, but it's
79not done by default on servers that doesn't support that command.")
80
82 81
83(defvoo nnimap-connection-alist nil) 82(defvoo nnimap-connection-alist nil)
84 83
@@ -92,14 +91,14 @@ textual parts.")
92 "Internal variable with default value for `nnimap-split-download-body'.") 91 "Internal variable with default value for `nnimap-split-download-body'.")
93 92
94(defstruct nnimap 93(defstruct nnimap
95 group process commands capabilities select-result newlinep) 94 group process commands capabilities select-result newlinep server)
96 95
97(defvar nnimap-object nil) 96(defvar nnimap-object nil)
98 97
99(defvar nnimap-mark-alist 98(defvar nnimap-mark-alist
100 '((read "\\Seen") 99 '((read "\\Seen" %Seen)
101 (tick "\\Flagged") 100 (tick "\\Flagged" %Flagged)
102 (reply "\\Answered") 101 (reply "\\Answered" %Answered)
103 (expire "gnus-expire") 102 (expire "gnus-expire")
104 (dormant "gnus-dormant") 103 (dormant "gnus-dormant")
105 (score "gnus-score") 104 (score "gnus-score")
@@ -213,7 +212,8 @@ textual parts.")
213 (buffer-disable-undo) 212 (buffer-disable-undo)
214 (gnus-add-buffer) 213 (gnus-add-buffer)
215 (set (make-local-variable 'after-change-functions) nil) 214 (set (make-local-variable 'after-change-functions) nil)
216 (set (make-local-variable 'nnimap-object) (make-nnimap)) 215 (set (make-local-variable 'nnimap-object)
216 (make-nnimap :server (nnoo-current-server 'nnimap)))
217 (push (list buffer (current-buffer)) nnimap-connection-alist) 217 (push (list buffer (current-buffer)) nnimap-connection-alist)
218 (current-buffer))) 218 (current-buffer)))
219 219
@@ -421,8 +421,9 @@ textual parts.")
421 (goto-char (point-max)) 421 (goto-char (point-max))
422 (cond 422 (cond
423 (marks 423 (marks
424 (setq high (nth 3 (car marks)) 424 (let ((uidnext (nth 5 (car marks))))
425 low (nth 4 (car marks)))) 425 (setq high (or (nth 3 (car marks)) (1- uidnext))
426 low (or (nth 4 (car marks)) uidnext))))
426 ((re-search-backward "UIDNEXT \\([0-9]+\\)" nil t) 427 ((re-search-backward "UIDNEXT \\([0-9]+\\)" nil t)
427 (setq high (1- (string-to-number (match-string 1))) 428 (setq high (1- (string-to-number (match-string 1)))
428 low 1))))) 429 low 1)))))
@@ -502,7 +503,8 @@ textual parts.")
502 nil) 503 nil)
503 (t 504 (t
504 (let ((deletable-articles 505 (let ((deletable-articles
505 (if force 506 (if (or force
507 (eq nnmail-expiry-wait 'immediate))
506 articles 508 articles
507 (gnus-sorted-intersection 509 (gnus-sorted-intersection
508 articles 510 articles
@@ -587,9 +589,9 @@ textual parts.")
587 589
588(deffoo nnimap-request-scan (&optional group server) 590(deffoo nnimap-request-scan (&optional group server)
589 (when (and (nnimap-possibly-change-group nil server) 591 (when (and (nnimap-possibly-change-group nil server)
590 (equal group nnimap-inbox)
591 nnimap-inbox 592 nnimap-inbox
592 nnimap-split-methods) 593 nnimap-split-methods)
594 (message "nnimap %s splitting mail..." server)
593 (nnimap-split-incoming-mail))) 595 (nnimap-split-incoming-mail)))
594 596
595(defun nnimap-marks-to-flags (marks) 597(defun nnimap-marks-to-flags (marks)
@@ -667,6 +669,7 @@ textual parts.")
667 sequences responses) 669 sequences responses)
668 (when groups 670 (when groups
669 (with-current-buffer (nnimap-buffer) 671 (with-current-buffer (nnimap-buffer)
672 (setf (nnimap-group nnimap-object) nil)
670 (dolist (group groups) 673 (dolist (group groups)
671 (push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t)) 674 (push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t))
672 group) 675 group)
@@ -716,6 +719,7 @@ textual parts.")
716 groups)) 719 groups))
717 ;; Then request the data. 720 ;; Then request the data.
718 (erase-buffer) 721 (erase-buffer)
722 (setf (nnimap-group nnimap-object) nil)
719 (dolist (elem groups) 723 (dolist (elem groups)
720 (if (and qresyncp 724 (if (and qresyncp
721 (nth 2 elem)) 725 (nth 2 elem))
@@ -773,7 +777,8 @@ textual parts.")
773 777
774(defun nnimap-update-info (info marks) 778(defun nnimap-update-info (info marks)
775 (when marks 779 (when marks
776 (destructuring-bind (existing flags high low uidnext start-article) marks 780 (destructuring-bind (existing flags high low uidnext start-article
781 permanent-flags) marks
777 (let ((group (gnus-info-group info)) 782 (let ((group (gnus-info-group info))
778 (completep (and start-article 783 (completep (and start-article
779 (= start-article 1)))) 784 (= start-article 1))))
@@ -784,16 +789,18 @@ textual parts.")
784 (if high 789 (if high
785 (cons low high) 790 (cons low high)
786 ;; No articles in this group. 791 ;; No articles in this group.
787 (cons (1- uidnext) uidnext))) 792 (cons uidnext (1- uidnext))))
788 (setcdr (gnus-active group) high)) 793 (setcdr (gnus-active group) (or high (1- uidnext))))
794 (unless high
795 (setq high (1- uidnext)))
789 ;; Then update the list of read articles. 796 ;; Then update the list of read articles.
790 (let* ((unread 797 (let* ((unread
791 (gnus-compress-sequence 798 (gnus-compress-sequence
792 (gnus-set-difference 799 (gnus-set-difference
793 (gnus-set-difference 800 (gnus-set-difference
794 existing 801 existing
795 (cdr (assoc "\\Seen" flags))) 802 (cdr (assoc '%Seen flags)))
796 (cdr (assoc "\\Flagged" flags))))) 803 (cdr (assoc '%Flagged flags)))))
797 (read (gnus-range-difference 804 (read (gnus-range-difference
798 (cons start-article high) unread))) 805 (cons start-article high) unread)))
799 (when (> start-article 1) 806 (when (> start-article 1)
@@ -815,8 +822,10 @@ textual parts.")
815 (push (cons 'active (gnus-active group)) marks))) 822 (push (cons 'active (gnus-active group)) marks)))
816 (dolist (type (cdr nnimap-mark-alist)) 823 (dolist (type (cdr nnimap-mark-alist))
817 (let ((old-marks (assoc (car type) marks)) 824 (let ((old-marks (assoc (car type) marks))
818 (new-marks (gnus-compress-sequence 825 (new-marks
819 (cdr (assoc (cadr type) flags))))) 826 (gnus-compress-sequence
827 (cdr (or (assoc (caddr type) flags) ; %Flagged
828 (assoc (cadr type) flags)))))) ; "\Flagged"
820 (setq marks (delq old-marks marks)) 829 (setq marks (delq old-marks marks))
821 (pop old-marks) 830 (pop old-marks)
822 (when (and old-marks 831 (when (and old-marks
@@ -838,12 +847,13 @@ textual parts.")
838 (push (list group info active) nnimap-current-infos)))) 847 (push (list group info active) nnimap-current-infos))))
839 848
840(defun nnimap-flags-to-marks (groups) 849(defun nnimap-flags-to-marks (groups)
841 (let (data group totalp uidnext articles start-article mark) 850 (let (data group totalp uidnext articles start-article mark permanent-flags)
842 (dolist (elem groups) 851 (dolist (elem groups)
843 (setq group (car elem) 852 (setq group (car elem)
844 uidnext (cadr elem) 853 uidnext (nth 1 elem)
845 start-article (caddr elem) 854 start-article (nth 2 elem)
846 articles (cdddr elem)) 855 permanent-flags (nth 3 elem)
856 articles (nthcdr 4 elem))
847 (let ((high (caar articles)) 857 (let ((high (caar articles))
848 marks low existing) 858 marks low existing)
849 (dolist (article articles) 859 (dolist (article articles)
@@ -853,36 +863,49 @@ textual parts.")
853 (setq mark (assoc flag marks)) 863 (setq mark (assoc flag marks))
854 (if (not mark) 864 (if (not mark)
855 (push (list flag (car article)) marks) 865 (push (list flag (car article)) marks)
856 (setcdr mark (cons (car article) (cdr mark))))) 866 (setcdr mark (cons (car article) (cdr mark))))))
857 (push (list group existing marks high low uidnext start-article) 867 (push (list group existing marks high low uidnext start-article
858 data)))) 868 permanent-flags)
869 data)))
859 data)) 870 data))
860 871
861(defun nnimap-parse-flags (sequences) 872(defun nnimap-parse-flags (sequences)
862 (goto-char (point-min)) 873 (goto-char (point-min))
863 (let (start end articles groups uidnext elems) 874 ;; Change \Delete etc to %Delete, so that the reader can read it.
875 (subst-char-in-region (point-min) (point-max)
876 ?\\ ?% t)
877 (let (start end articles groups uidnext elems permanent-flags)
864 (dolist (elem sequences) 878 (dolist (elem sequences)
865 (destructuring-bind (group-sequence flag-sequence totalp group) elem 879 (destructuring-bind (group-sequence flag-sequence totalp group) elem
880 (setq start (point))
866 ;; The EXAMINE was successful. 881 ;; The EXAMINE was successful.
867 (when (and (search-forward (format "\n%d OK " group-sequence) nil t) 882 (when (and (search-forward (format "\n%d OK " group-sequence) nil t)
868 (progn 883 (progn
869 (forward-line 1) 884 (forward-line 1)
870 (setq start (point)) 885 (setq end (point))
871 (if (re-search-backward "UIDNEXT \\([0-9]+\\)" 886 (goto-char start)
872 (or end (point-min)) t) 887 (setq permanent-flags
873 (setq uidnext (string-to-number (match-string 1))) 888 (and (search-forward "PERMANENTFLAGS "
874 (setq uidnext nil)) 889 (or end (point-min)) t)
875 (goto-char start)) 890 (read (current-buffer))))
891 (goto-char start)
892 (setq uidnext
893 (and (search-forward "UIDNEXT "
894 (or end (point-min)) t)
895 (read (current-buffer))))
896 (goto-char end)
897 (forward-line -1))
876 ;; The UID FETCH FLAGS was successful. 898 ;; The UID FETCH FLAGS was successful.
877 (search-forward (format "\n%d OK " flag-sequence) nil t)) 899 (search-forward (format "\n%d OK " flag-sequence) nil t))
878 (setq end (point)) 900 (setq start (point))
879 (goto-char start) 901 (goto-char end)
880 (while (re-search-forward "^\\* [0-9]+ FETCH (\\(.*\\))" end t) 902 (while (search-forward " FETCH " start t)
881 (setq elems (nnimap-parse-line (match-string 1))) 903 (setq elems (read (current-buffer)))
882 (push (cons (string-to-number (cadr (member "UID" elems))) 904 (push (cons (cadr (memq 'UID elems))
883 (cadr (member "FLAGS" elems))) 905 (cadr (memq 'FLAGS elems)))
884 articles)) 906 articles))
885 (push (nconc (list group uidnext totalp) articles) groups) 907 (push (nconc (list group uidnext totalp permanent-flags) articles)
908 groups)
886 (setq articles nil)))) 909 (setq articles nil))))
887 groups)) 910 groups))
888 911
@@ -1085,32 +1108,38 @@ textual parts.")
1085 (nnmail-split-incoming (current-buffer) 1108 (nnmail-split-incoming (current-buffer)
1086 #'nnimap-save-mail-spec 1109 #'nnimap-save-mail-spec
1087 nil nil 1110 nil nil
1088 #'nnimap-dummy-active-number) 1111 #'nnimap-dummy-active-number
1112 #'nnimap-save-mail-spec)
1089 (when nnimap-incoming-split-list 1113 (when nnimap-incoming-split-list
1090 (let ((specs (nnimap-make-split-specs nnimap-incoming-split-list)) 1114 (let ((specs (nnimap-make-split-specs nnimap-incoming-split-list))
1091 sequences) 1115 sequences junk-articles)
1092 ;; Create any groups that doesn't already exist on the 1116 ;; Create any groups that doesn't already exist on the
1093 ;; server first. 1117 ;; server first.
1094 (dolist (spec specs) 1118 (dolist (spec specs)
1095 (unless (member (car spec) groups) 1119 (when (and (not (member (car spec) groups))
1120 (not (eq (car spec) 'junk)))
1096 (nnimap-command "CREATE %S" (utf7-encode (car spec) t)))) 1121 (nnimap-command "CREATE %S" (utf7-encode (car spec) t))))
1097 ;; Then copy over all the messages. 1122 ;; Then copy over all the messages.
1098 (erase-buffer) 1123 (erase-buffer)
1099 (dolist (spec specs) 1124 (dolist (spec specs)
1100 (let ((group (car spec)) 1125 (let ((group (car spec))
1101 (ranges (cdr spec))) 1126 (ranges (cdr spec)))
1102 (push (list (nnimap-send-command "UID COPY %s %S" 1127 (if (eq group 'junk)
1103 (nnimap-article-ranges ranges) 1128 (setq junk-articles ranges)
1104 (utf7-encode group t)) 1129 (push (list (nnimap-send-command
1105 ranges) 1130 "UID COPY %s %S"
1106 sequences))) 1131 (nnimap-article-ranges ranges)
1132 (utf7-encode group t))
1133 ranges)
1134 sequences))))
1107 ;; Wait for the last COPY response... 1135 ;; Wait for the last COPY response...
1108 (when sequences 1136 (when sequences
1109 (nnimap-wait-for-response (caar sequences)) 1137 (nnimap-wait-for-response (caar sequences))
1110 ;; And then mark the successful copy actions as deleted, 1138 ;; And then mark the successful copy actions as deleted,
1111 ;; and possibly expunge them. 1139 ;; and possibly expunge them.
1112 (nnimap-mark-and-expunge-incoming 1140 (nnimap-mark-and-expunge-incoming
1113 (nnimap-parse-copied-articles sequences))))))))) 1141 (nnimap-parse-copied-articles sequences))
1142 (nnimap-mark-and-expunge-incoming junk-articles))))))))
1114 1143
1115(defun nnimap-mark-and-expunge-incoming (range) 1144(defun nnimap-mark-and-expunge-incoming (range)
1116 (when range 1145 (when range
@@ -1125,7 +1154,7 @@ textual parts.")
1125 (setq sequence (nnimap-send-command "UID EXPUNGE %s" range))) 1154 (setq sequence (nnimap-send-command "UID EXPUNGE %s" range)))
1126 ;; If it doesn't support UID EXPUNGE, then we only expunge if the 1155 ;; If it doesn't support UID EXPUNGE, then we only expunge if the
1127 ;; user has configured it. 1156 ;; user has configured it.
1128 (nnimap-expunge-inbox 1157 (nnimap-expunge
1129 (setq sequence (nnimap-send-command "EXPUNGE")))) 1158 (setq sequence (nnimap-send-command "EXPUNGE"))))
1130 (nnimap-wait-for-response sequence)))) 1159 (nnimap-wait-for-response sequence))))
1131 1160
@@ -1142,8 +1171,8 @@ textual parts.")
1142 (let (new) 1171 (let (new)
1143 (dolist (elem flags) 1172 (dolist (elem flags)
1144 (when (or (null (cdr elem)) 1173 (when (or (null (cdr elem))
1145 (and (not (member "\\Deleted" (cdr elem))) 1174 (and (not (memq '%Deleted (cdr elem)))
1146 (not (member "\\Seen" (cdr elem))))) 1175 (not (memq '%Seen (cdr elem)))))
1147 (push (car elem) new))) 1176 (push (car elem) new)))
1148 (gnus-compress-sequence (nreverse new)))) 1177 (gnus-compress-sequence (nreverse new))))
1149 1178
@@ -1190,7 +1219,10 @@ textual parts.")
1190 (if (not (re-search-forward "X-nnimap-article: \\([0-9]+\\)" nil t)) 1219 (if (not (re-search-forward "X-nnimap-article: \\([0-9]+\\)" nil t))
1191 (error "Invalid nnimap mail") 1220 (error "Invalid nnimap mail")
1192 (setq article (string-to-number (match-string 1)))) 1221 (setq article (string-to-number (match-string 1))))
1193 (push (list article group-art) 1222 (push (list article
1223 (if (eq group-art 'junk)
1224 (list (cons 'junk 1))
1225 group-art))
1194 nnimap-incoming-split-list))) 1226 nnimap-incoming-split-list)))
1195 1227
1196(provide 'nnimap) 1228(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."
963 (goto-char end))) 963 (goto-char end)))
964 count)) 964 count))
965 965
966(defun nnmail-process-mmdf-mail-format (func artnum-func) 966(defun nnmail-process-mmdf-mail-format (func artnum-func &optional junk-func)
967 (let ((delim "^\^A\^A\^A\^A$") 967 (let ((delim "^\^A\^A\^A\^A$")
968 (case-fold-search t) 968 (case-fold-search t)
969 (count 0) 969 (count 0)
@@ -1011,7 +1011,7 @@ If SOURCE is a directory spec, try to return the group name component."
1011 (narrow-to-region start (point)) 1011 (narrow-to-region start (point))
1012 (goto-char (point-min)) 1012 (goto-char (point-min))
1013 (incf count) 1013 (incf count)
1014 (nnmail-check-duplication message-id func artnum-func) 1014 (nnmail-check-duplication message-id func artnum-func junk-func)
1015 (setq end (point-max)))) 1015 (setq end (point-max))))
1016 (goto-char end) 1016 (goto-char end)
1017 (forward-line 2))) 1017 (forward-line 2)))
@@ -1056,7 +1056,7 @@ If SOURCE is a directory spec, try to return the group name component."
1056 "Non-nil means group names are not encoded.") 1056 "Non-nil means group names are not encoded.")
1057 1057
1058(defun nnmail-split-incoming (incoming func &optional exit-func 1058(defun nnmail-split-incoming (incoming func &optional exit-func
1059 group artnum-func) 1059 group artnum-func junk-func)
1060 "Go through the entire INCOMING file and pick out each individual mail. 1060 "Go through the entire INCOMING file and pick out each individual mail.
1061FUNC will be called with the buffer narrowed to each mail. 1061FUNC will be called with the buffer narrowed to each mail.
1062INCOMING can also be a buffer object. In that case, the mail 1062INCOMING can also be a buffer object. In that case, the mail
@@ -1087,7 +1087,8 @@ will be copied over from that buffer."
1087 (looking-at "BABYL OPTIONS:")) 1087 (looking-at "BABYL OPTIONS:"))
1088 (nnmail-process-babyl-mail-format func artnum-func)) 1088 (nnmail-process-babyl-mail-format func artnum-func))
1089 ((looking-at "\^A\^A\^A\^A") 1089 ((looking-at "\^A\^A\^A\^A")
1090 (nnmail-process-mmdf-mail-format func artnum-func)) 1090 (nnmail-process-mmdf-mail-format
1091 func artnum-func junk-func))
1091 ((looking-at "Return-Path:") 1092 ((looking-at "Return-Path:")
1092 (nnmail-process-maildir-mail-format func artnum-func)) 1093 (nnmail-process-maildir-mail-format func artnum-func))
1093 (t 1094 (t
@@ -1096,7 +1097,7 @@ will be copied over from that buffer."
1096 (funcall exit-func)) 1097 (funcall exit-func))
1097 (kill-buffer (current-buffer)))))) 1098 (kill-buffer (current-buffer))))))
1098 1099
1099(defun nnmail-article-group (func &optional trace) 1100(defun nnmail-article-group (func &optional trace junk-func)
1100 "Look at the headers and return an alist of groups that match. 1101 "Look at the headers and return an alist of groups that match.
1101FUNC will be called with the group name to determine the article number." 1102FUNC will be called with the group name to determine the article number."
1102 (let ((methods (or nnmail-split-methods '(("bogus" "")))) 1103 (let ((methods (or nnmail-split-methods '(("bogus" ""))))
@@ -1163,9 +1164,10 @@ FUNC will be called with the group name to determine the article number."
1163 ;; The article may be "cross-posted" to `junk'. What 1164 ;; The article may be "cross-posted" to `junk'. What
1164 ;; to do? Just remove the `junk' spec. Don't really 1165 ;; to do? Just remove the `junk' spec. Don't really
1165 ;; see anything else to do... 1166 ;; see anything else to do...
1166 (let (elem) 1167 (when (and (memq 'junk split)
1167 (while (setq elem (car (memq 'junk split))) 1168 junk-func)
1168 (setq split (delq elem split)))) 1169 (funcall junk-func 'junk))
1170 (setq split (delq 'junk split))
1169 (when split 1171 (when split
1170 (setq group-art 1172 (setq group-art
1171 (mapcar 1173 (mapcar
@@ -1714,7 +1716,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
1714 (message-narrow-to-head) 1716 (message-narrow-to-head)
1715 (message-fetch-field header)))) 1717 (message-fetch-field header))))
1716 1718
1717(defun nnmail-check-duplication (message-id func artnum-func) 1719(defun nnmail-check-duplication (message-id func artnum-func
1720 &optional junk-func)
1718 (run-hooks 'nnmail-prepare-incoming-message-hook) 1721 (run-hooks 'nnmail-prepare-incoming-message-hook)
1719 ;; If this is a duplicate message, then we do not save it. 1722 ;; If this is a duplicate message, then we do not save it.
1720 (let* ((duplication (nnmail-cache-id-exists-p message-id)) 1723 (let* ((duplication (nnmail-cache-id-exists-p message-id))
@@ -1739,7 +1742,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
1739 (cond 1742 (cond
1740 ((not duplication) 1743 ((not duplication)
1741 (funcall func (setq group-art 1744 (funcall func (setq group-art
1742 (nreverse (nnmail-article-group artnum-func)))) 1745 (nreverse (nnmail-article-group
1746 artnum-func nil junk-func))))
1743 (nnmail-cache-insert message-id (caar group-art))) 1747 (nnmail-cache-insert message-id (caar group-art)))
1744 ((eq action 'delete) 1748 ((eq action 'delete)
1745 (setq group-art nil)) 1749 (setq group-art nil))
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-26 03:22:54 +0000