Mercurial > emacs
changeset 110486:1ad1adb298a3
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.
| author | Katsumi Yamaoka <yamaoka@jpl.org> |
|---|---|
| date | Thu, 23 Sep 2010 00:30:37 +0000 |
| parents | 14057cf8379c |
| children | d3b676998c45 |
| files | doc/misc/gnus.texi lisp/ChangeLog lisp/calendar/time-date.el lisp/gnus/ChangeLog lisp/gnus/gnus-group.el lisp/gnus/gnus-html.el lisp/gnus/gnus-int.el lisp/gnus/gnus-start.el lisp/gnus/gnus-sum.el lisp/gnus/gnus.el lisp/gnus/nnimap.el lisp/gnus/nnmail.el |
| diffstat | 12 files changed, 426 insertions(+), 277 deletions(-) [+] |
line wrap: on
line diff
--- a/doc/misc/gnus.texi Thu Sep 23 01:14:00 2010 +0200 +++ b/doc/misc/gnus.texi Thu Sep 23 00:30:37 2010 +0000 @@ -1996,8 +1996,7 @@ @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
--- a/lisp/ChangeLog Thu Sep 23 01:14:00 2010 +0200 +++ b/lisp/ChangeLog Thu Sep 23 00:30:37 2010 +0000 @@ -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.
--- a/lisp/calendar/time-date.el Thu Sep 23 01:14:00 2010 +0200 +++ b/lisp/calendar/time-date.el Thu Sep 23 00:30:37 2010 +0000 @@ -97,20 +97,20 @@ (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
--- a/lisp/gnus/ChangeLog Thu Sep 23 01:14:00 2010 +0200 +++ b/lisp/gnus/ChangeLog Thu Sep 23 00:30:37 2010 +0000 @@ -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.
--- a/lisp/gnus/gnus-group.el Thu Sep 23 01:14:00 2010 +0200 +++ b/lisp/gnus/gnus-group.el Thu Sep 23 00:30:37 2010 +0000 @@ -292,14 +292,8 @@ :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 @@ 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 @@ ?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 @@ '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.
--- a/lisp/gnus/gnus-html.el Thu Sep 23 01:14:00 2010 +0200 +++ b/lisp/gnus/gnus-html.el Thu Sep 23 00:30:37 2010 +0000 @@ -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 @@ (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 @@ (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 @@ (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 @@ :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 @@ ;; 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 @@ (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 @@ (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 @@ 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 @@ 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
--- a/lisp/gnus/gnus-int.el Thu Sep 23 01:14:00 2010 +0200 +++ b/lisp/gnus/gnus-int.el Thu Sep 23 00:30:37 2010 +0000 @@ -226,10 +226,18 @@ (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 @@ (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)
--- a/lisp/gnus/gnus-start.el Thu Sep 23 01:14:00 2010 +0200 +++ b/lisp/gnus/gnus-start.el Thu Sep 23 00:30:37 2010 +0000 @@ -1757,8 +1757,7 @@ (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 @@ (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 @@ (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 @@ (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))
--- a/lisp/gnus/gnus-sum.el Thu Sep 23 01:14:00 2010 +0200 +++ b/lisp/gnus/gnus-sum.el Thu Sep 23 00:30:37 2010 +0000 @@ -5976,6 +5976,10 @@ (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
--- a/lisp/gnus/gnus.el Thu Sep 23 01:14:00 2010 +0200 +++ b/lisp/gnus/gnus.el Thu Sep 23 00:30:37 2010 +0000 @@ -3566,7 +3566,7 @@ (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 @@ (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 @@ (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)))
--- a/lisp/gnus/nnimap.el Thu Sep 23 01:14:00 2010 +0200 +++ b/lisp/gnus/nnimap.el Thu Sep 23 00:30:37 2010 +0000 @@ -62,11 +62,6 @@ (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 @@ 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 @@ "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 @@ (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 @@ (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 @@ nil) (t (let ((deletable-articles - (if force + (if (or force + (eq nnmail-expiry-wait 'immediate)) articles (gnus-sorted-intersection articles @@ -587,9 +589,9 @@ (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 @@ 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 @@ 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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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)
--- a/lisp/gnus/nnmail.el Thu Sep 23 01:14:00 2010 +0200 +++ b/lisp/gnus/nnmail.el Thu Sep 23 00:30:37 2010 +0000 @@ -963,7 +963,7 @@ (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 @@ (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 @@ "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 @@ (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 @@ (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 @@ ;; 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 @@ (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 @@ (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))