mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-27 07:37:33 +00:00
Code Issues Releases Activity

Merge Changes made in Gnus trunk.

Browse Source 
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.
This commit is contained in:
Gnus developers 2010-09-23 00:30:37 +00:00 committed by Katsumi Yamaoka
parent 0521215472
commit b069e5a697
12 changed files with 425 additions and 276 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
doc/misc/gnus.texi
View File

@ -1996,8 +1996,7 @@ functions for snarfing info on the group.
@vindex gnus-group-update-hook
@findex gnus-group-highlight-line
@code{gnus-group-update-hook} is called when a group line is changed.
It will not be called when @code{gnus-visual} is @code{nil}. This hook
calls @code{gnus-group-highlight-line} by default.
It will not be called when @code{gnus-visual} is @code{nil}.
@node Group Maneuvering

5
lisp/ChangeLog
View File

@ -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.

20
lisp/calendar/time-date.el
View File

@ -97,20 +97,20 @@ and type 2 is the list (HIGH LOW MICRO)."
(autoload 'timezone-make-date-arpa-standard "timezone")
;;;###autoload
;; `parse-time-string' isn't sufficiently general or robust. It fails
;; to grok some of the formats that timezone does (e.g. dodgy
;; post-2000 stuff from some Elms) and either fails or returns bogus
;; values. timezone-make-date-arpa-standard should help.
(defun date-to-time (date)
"Parse a string DATE that represents a date-time and return a time value.
If DATE lacks timezone information, GMT is assumed."
(condition-case ()
(apply 'encode-time
(parse-time-string
;; `parse-time-string' isn't sufficiently general or
;; robust. It fails to grok some of the formats that
;; timezone does (e.g. dodgy post-2000 stuff from some
;; Elms) and either fails or returns bogus values. Lars
;; reverted this change, but that loses non-trivially
;; often for me. -- fx
(timezone-make-date-arpa-standard date)))
(error (error "Invalid date: %s" date))))
(apply 'encode-time (parse-time-string date))
(error (condition-case ()
(apply 'encode-time
(parse-time-string
(timezone-make-date-arpa-standard date)))
(error (error "Invalid date: %s" date))))))
;; Bit of a mess. Emacs has float-time since at least 21.1.
;; This file is synced to Gnus, and XEmacs packages may have been written

124
lisp/gnus/ChangeLog
View File

@ -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.

184
lisp/gnus/gnus-group.el
View File

@ -292,14 +292,8 @@ If you want to modify the group buffer, you can use this hook."
:group 'gnus-exit
:type 'hook)
(defcustom gnus-group-update-hook '(gnus-group-highlight-line gnus-group-add-icon)
"Hook called when a group line is changed.
The hook will not be called if `gnus-visual' is nil.
The default functions `gnus-group-highlight-line' will highlight
the line according to the `gnus-group-highlight' variable, and
`gnus-group-add-icon' will add an icon according to
`gnus-group-icon-list'"
(defcustom gnus-group-update-hook nil
"Hook called when a group line is changed."
:group 'gnus-group-visual
:type 'hook)
@ -429,7 +423,6 @@ group: The name of the group.
unread: The number of unread articles in the group.
method: The select method used.
mailp: Whether it's a mail group or not.
newsp: Whether it's a news group or not
level: The level of the group.
score: The score of the group.
ticked: The number of ticked articles."
@ -1579,7 +1572,7 @@ if it is a string, only list groups matching REGEXP."
?m ? ))
(gnus-tmp-moderated-string
(if (eq gnus-tmp-moderated ?m) "(m)" ""))
(gnus-tmp-group-icon (propertize " " 'gnus-group-icon t))
(gnus-tmp-group-icon (gnus-group-get-icon gnus-tmp-qualified-group))
(gnus-tmp-news-server (or (cadr gnus-tmp-method) ""))
(gnus-tmp-news-method (or (car gnus-tmp-method) ""))
(gnus-tmp-news-method-string
@ -1626,108 +1619,85 @@ if it is a string, only list groups matching REGEXP."
'gnus-tool-bar-update))
(forward-line -1)
(when (inline (gnus-visual-p 'group-highlight 'highlight))
(gnus-run-hooks 'gnus-group-update-hook))
(gnus-group-highlight-line gnus-tmp-group beg end))
(gnus-run-hooks 'gnus-group-update-hook)
(forward-line)
;; Allow XEmacs to remove front-sticky text properties.
(gnus-group-remove-excess-properties)))
(defun gnus-group-highlight-line ()
"Highlight the current line according to `gnus-group-highlight'."
(let* ((list gnus-group-highlight)
(p (point))
(end (point-at-eol))
;; now find out where the line starts and leave point there.
(beg (progn (beginning-of-line) (point)))
(group (gnus-group-group-name))
(entry (gnus-group-entry group))
(unread (if (numberp (car entry)) (car entry) 0))
(active (gnus-active group))
(total (if active (1+ (- (cdr active) (car active))) 0))
(info (nth 2 entry))
(method (inline (gnus-server-get-method group (gnus-info-method info))))
(marked (gnus-info-marks info))
(mailp (apply 'append
(mapcar
(lambda (x)
(memq x (assoc (symbol-name
(car (or method gnus-select-method)))
gnus-valid-select-methods)))
'(mail post-mail))))
(level (or (gnus-info-level info) gnus-level-killed))
(score (or (gnus-info-score info) 0))
(ticked (gnus-range-length (cdr (assq 'tick marked))))
(group-age (gnus-group-timestamp-delta group))
(inhibit-read-only t))
;; FIXME: http://thread.gmane.org/gmane.emacs.gnus.general/65451/focus=65465
;; ======================================================================
;; From: Richard Stallman
;; Subject: Re: Rewriting gnus-group-highlight-line (was: [...])
;; Cc: ding@gnus.org
;; Date: Sat, 27 Oct 2007 19:41:20 -0400
;; Message-ID: <E1IlvHM-0006TS-7t@fencepost.gnu.org>
;;
;; [...]
;; The kludge is that the alist elements contain expressions that refer
;; to local variables with short names. Perhaps write your own tiny
;; evaluator that handles just `and', `or', and numeric comparisons
;; and just a few specific variables.
;; ======================================================================
;;
;; Similar for other evaluated variables. Grep for risky-local-variable
;; to find them! -- rsteib
;;
;; Eval the cars of the lists until we find a match.
(while (and list
(not (eval (caar list))))
(setq list (cdr list)))
(let ((face (cdar list)))
(unless (eq face (get-text-property beg 'face))
(gnus-put-text-property-excluding-characters-with-faces
beg end 'face
(setq face (if (boundp face) (symbol-value face) face)))
(gnus-extent-start-open beg)))
(goto-char p)))
(defun gnus-group-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-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-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.

158
lisp/gnus/gnus-html.el
View File

@ -36,13 +36,20 @@
(require 'url)
(require 'url-cache)
(require 'xml)
(require 'browse-url)
(defcustom gnus-html-image-cache-ttl (days-to-time 7)
"Time in seconds used to cache the image on disk."
"Time used to determine if we should use images from the cache."
:version "24.1"
:group 'gnus-art
:type 'integer)
(defcustom gnus-html-image-automatic-caching t
"Whether automatically cache retrieve images."
:version "24.1"
:group 'gnus-art
:type 'boolean)
(defcustom gnus-html-frame-width 70
"What width to use when rendering HTML."
:version "24.1"
@ -81,6 +88,10 @@ fit these criteria."
(define-key map [tab] 'widget-forward)
map))
(defun gnus-html-encode-url (url)
"Encode URL."
(browse-url-url-encode-chars url "[)$ ]"))
(defun gnus-html-cache-expired (url ttl)
"Check if URL is cached for more than TTL."
(cond (url-standalone-mode
@ -155,7 +166,7 @@ fit these criteria."
(delete-region (match-beginning 0) (match-end 0)))
(setq end (point))
(when (string-match "src=\"\\([^\"]+\\)" parameters)
(setq url (match-string 1 parameters))
(setq url (gnus-html-encode-url (match-string 1 parameters)))
(gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url)
(if (string-match "^cid:\\(.*\\)" url)
;; URLs with cid: have their content stashed in other
@ -177,6 +188,7 @@ fit these criteria."
(let ((alt-text (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)"
parameters)
(xml-substitute-special (match-string 2 parameters)))))
(gnus-put-text-property start end 'gnus-image-url url)
(if (gnus-html-image-url-blocked-p
url
(if (buffer-live-p gnus-summary-buffer)
@ -191,13 +203,9 @@ fit these criteria."
:keymap gnus-html-image-map
:button-keymap gnus-html-image-map)
(let ((overlay (gnus-make-overlay start end))
(spec (list url
(set-marker (make-marker) start)
(set-marker (make-marker) end)
alt-text)))
(spec (list url alt-text)))
(gnus-overlay-put overlay 'local-map gnus-html-image-map)
(gnus-overlay-put overlay 'gnus-image spec)
(gnus-put-text-property start end 'gnus-image-url url)
(gnus-put-text-property
start end
'gnus-image spec)))
@ -224,13 +232,9 @@ Use ALT-TEXT for the image string."
;; asynchronously.
(gnus-html-schedule-image-fetching
(current-buffer)
(list url
(set-marker (make-marker) start)
(set-marker (make-marker) end)
alt-text))
(list url alt-text))
;; It's already cached, so just insert it.
(gnus-html-put-image (gnus-html-get-image-data url)
start end url alt-text)))
(gnus-html-put-image (gnus-html-get-image-data url) url alt-text)))
(defun gnus-html-wash-tags ()
(let (tag parameters string start end images url)
@ -347,22 +351,17 @@ Use ALT-TEXT for the image string."
(list buffer image))))
(defun gnus-html-image-fetched (status buffer image)
(url-store-in-cache (current-buffer))
(when (and (search-forward "\n\n" nil t)
(buffer-live-p buffer)
;; If the `image' has no marker, do not replace anything
(cadr image)
;; If the position of the marker is 1, then that
;; means that the text it was in has been deleted;
;; i.e., that the user has selected a different
;; article before the image arrived.
(not (= (marker-position (cadr image))
(with-current-buffer buffer
(point-min)))))
(let ((data (buffer-substring (point) (point-max))))
(with-current-buffer buffer
(let ((inhibit-read-only t))
(gnus-html-put-image data (cadr image) (caddr image) (car image) (cadddr image))))))
"Callback function called when image has been fetched."
(unless (plist-get status :error)
(when gnus-html-image-automatic-caching
(url-store-in-cache (current-buffer)))
(when (and (or (search-forward "\n\n" nil t)
(search-forward "\r\n\r\n" nil t))
(buffer-live-p buffer))
(let ((data (buffer-substring (point) (point-max))))
(with-current-buffer buffer
(let ((inhibit-read-only t))
(gnus-html-put-image data (car image) (cadr image)))))))
(kill-buffer (current-buffer)))
(defun gnus-html-get-image-data (url)
@ -371,54 +370,61 @@ Return a string with image data."
(with-temp-buffer
(mm-disable-multibyte)
(url-cache-extract (url-cache-create-filename url))
(when (search-forward "\n\n" nil t)
(when (or (search-forward "\n\n" nil t)
(search-forward "\r\n\r\n" nil t))
(buffer-substring (point) (point-max)))))
(defun gnus-html-put-image (data start end &optional url alt-text)
(defun gnus-html-put-image (data url &optional alt-text)
(when (gnus-graphic-display-p)
(let* ((image (ignore-errors
(gnus-create-image data nil t)))
(size (and image
(if (featurep 'xemacs)
(cons (glyph-width image) (glyph-height image))
(image-size image t)))))
(save-excursion
(goto-char start)
(let ((alt-text (or alt-text (buffer-substring-no-properties start end))))
(if (and image
;; Kludge to avoid displaying 30x30 gif images, which
;; seems to be a signal of a broken image.
(not (and (if (featurep 'xemacs)
(glyphp image)
(listp image))
(eq (if (featurep 'xemacs)
(let ((d (cdadar (specifier-spec-list
(glyph-image image)))))
(and (vectorp d)
(aref d 0)))
(plist-get (cdr image) :type))
'gif)
(= (car size) 30)
(= (cdr size) 30))))
;; Good image, add it!
(let ((image (gnus-html-rescale-image image data size)))
(delete-region start end)
(gnus-put-image image alt-text 'external)
(gnus-put-text-property start (point) 'help-echo alt-text)
(gnus-overlay-put (gnus-make-overlay start (point)) 'local-map
gnus-html-displayed-image-map)
(gnus-put-text-property start (point) 'gnus-alt-text alt-text)
(when url
(gnus-put-text-property start (point) 'gnus-image-url url))
(gnus-add-image 'external image)
t)
;; Bad image, try to show something else
(delete-region start end)
(when (fboundp 'find-image)
(setq image (find-image '((:type xpm :file "lock-broken.xpm"))))
(gnus-put-image image alt-text 'internal)
(gnus-add-image 'internal image))
nil))))))
(let* ((start (text-property-any (point-min) (point-max) 'gnus-image-url url))
(end (when start
(next-single-property-change start 'gnus-image-url))))
;; Image found?
(when start
(let* ((image
(ignore-errors
(gnus-create-image data nil t)))
(size (and image
(if (featurep 'xemacs)
(cons (glyph-width image) (glyph-height image))
(image-size image t)))))
(save-excursion
(goto-char start)
(let ((alt-text (or alt-text (buffer-substring-no-properties start end))))
(if (and image
;; Kludge to avoid displaying 30x30 gif images, which
;; seems to be a signal of a broken image.
(not (and (if (featurep 'xemacs)
(glyphp image)
(listp image))
(eq (if (featurep 'xemacs)
(let ((d (cdadar (specifier-spec-list
(glyph-image image)))))
(and (vectorp d)
(aref d 0)))
(plist-get (cdr image) :type))
'gif)
(= (car size) 30)
(= (cdr size) 30))))
;; Good image, add it!
(let ((image (gnus-html-rescale-image image data size)))
(delete-region start end)
(gnus-put-image image alt-text 'external)
(gnus-put-text-property start (point) 'help-echo alt-text)
(gnus-overlay-put (gnus-make-overlay start (point)) 'local-map
gnus-html-displayed-image-map)
(gnus-put-text-property start (point) 'gnus-alt-text alt-text)
(when url
(gnus-put-text-property start (point) 'gnus-image-url url))
(gnus-add-image 'external image)
t)
;; Bad image, try to show something else
(when (fboundp 'find-image)
(delete-region start end)
(setq image (find-image '((:type xpm :file "lock-broken.xpm"))))
(gnus-put-image image alt-text 'internal)
(gnus-add-image 'internal image))
nil))))))))
(defun gnus-html-rescale-image (image data size)
(if (or (not (fboundp 'imagemagick-types))
@ -426,7 +432,7 @@ Return a string with image data."
image
(let* ((width (car size))
(height (cdr size))
(edges (window-pixel-edges (get-buffer-window (current-buffer))))
(edges (window-inside-pixel-edges (get-buffer-window (current-buffer))))
(window-width (truncate (* gnus-max-image-proportion
(- (nth 2 edges) (nth 0 edges)))))
(window-height (truncate (* gnus-max-image-proportion
@ -472,7 +478,7 @@ This only works if the article in question is HTML."
gnus-blocked-images)))
(save-match-data
(while (re-search-forward "<img.*src=[\"']\\([^\"']+\\)" nil t)
(let ((url (match-string 1)))
(let ((url (gnus-html-encode-url (match-string 1))))
(unless (gnus-html-image-url-blocked-p url blocked-images)
(when (gnus-html-cache-expired url gnus-html-image-cache-ttl)
(gnus-html-schedule-image-fetching nil

9
lisp/gnus/gnus-int.el
View File

@ -226,10 +226,18 @@ If it is down, start it up (again)."
(eq (nth 1 (assoc method gnus-opened-servers))
'denied))
(defvar gnus-backend-trace t)
(defun gnus-open-server (gnus-command-method)
"Open a connection to GNUS-COMMAND-METHOD."
(when (stringp gnus-command-method)
(setq gnus-command-method (gnus-server-to-method gnus-command-method)))
(when gnus-backend-trace
(with-current-buffer (get-buffer-create "*gnus trace*")
(buffer-disable-undo)
(goto-char (point-max))
(insert (format-time-string "%H:%M:%S")
(format " %S\n" gnus-command-method))))
(let ((elem (assoc gnus-command-method gnus-opened-servers))
(server (gnus-method-to-server-name gnus-command-method)))
;; If this method was previously denied, we just return nil.
@ -601,6 +609,7 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
(defun gnus-request-expire-articles (articles group &optional force)
(let* ((gnus-command-method (gnus-find-method-for-group group))
(gnus-inhibit-demon t)
(not-deleted
(funcall
(gnus-get-function gnus-command-method 'request-expire-articles)

14
lisp/gnus/gnus-start.el
View File

@ -1757,8 +1757,7 @@ If SCAN, request a scan of that group as well."
(when (gnus-check-backend-function
'retrieve-group-data-early (car method))
(when (gnus-check-backend-function 'request-scan (car method))
(dolist (info infos)
(gnus-request-scan (gnus-info-group info) method)))
(gnus-request-scan nil method))
(setcar (nthcdr 3 elem)
(gnus-retrieve-group-data-early method infos))))))
@ -1770,8 +1769,7 @@ If SCAN, request a scan of that group as well."
(gnus-read-active-for-groups method infos early-data)
(dolist (info infos)
(inline (gnus-get-unread-articles-in-group
info (gnus-active (gnus-info-group info))
t))))))
info (gnus-active (gnus-info-group info))))))))
(gnus-message 6 "Checking new news...done")))
(defun gnus-method-rank (type method)
@ -1806,8 +1804,7 @@ If SCAN, request a scan of that group as well."
(gnus-agent-save-active method))
((gnus-check-backend-function 'retrieve-groups (car method))
(when (gnus-check-backend-function 'request-scan (car method))
(dolist (info infos)
(gnus-request-scan (gnus-info-group info) method)))
(gnus-request-scan nil method))
(let (groups)
(gnus-read-active-file-2
(dolist (info infos (nreverse groups))
@ -2055,10 +2052,7 @@ If SCAN, request a scan of that group as well."
(gnus-online method))
(not gnus-agent))
(gnus-check-backend-function 'request-scan (car method)))
(if infos
(dolist (info infos)
(gnus-request-scan (gnus-info-group info) method))
(gnus-request-scan nil method)))
(gnus-request-scan nil method))
(cond
((and (eq gnus-read-active-file 'some)
(gnus-check-backend-function 'retrieve-groups (car method))

4
lisp/gnus/gnus-sum.el
View File

@ -5976,6 +5976,10 @@ If SELECT-ARTICLES, only select those articles from GROUP."
(when add
(push (list add 'add (list (cdr type))) delta-marks))
(when del
;; Don't delete marks from outside the active range. This
;; shouldn't happen, but is a sanity check.
(setq del (gnus-sorted-range-intersection
(gnus-active gnus-newsgroup-name) del))
(push (list del 'del (list (cdr type))) delta-marks))))
(when list

12
lisp/gnus/gnus.el
View File

@ -3566,7 +3566,7 @@ that that variable is buffer-local to the summary buffers."
(nth 1 method))))
method)))
(defsubst gnus-method-to-server (method &optional nocache)
(defsubst gnus-method-to-server (method &optional nocache no-enter-cache)
(catch 'server-name
(setq method (or method gnus-select-method))
@ -3592,7 +3592,9 @@ that that variable is buffer-local to the summary buffers."
(format "%s" (car method))
(format "%s:%s" (car method) (cadr method))))
(name-method (cons name method)))
(unless (member name-method gnus-server-method-cache)
(when (and (not (member name-method gnus-server-method-cache))
(not no-enter-cache)
(not (assoc (car name-method) gnus-server-method-cache)))
(push name-method gnus-server-method-cache))
name)))
@ -3634,11 +3636,13 @@ that that variable is buffer-local to the summary buffers."
(while alist
(setq method (gnus-info-method (pop alist)))
(when (and (not (stringp method))
(equal server (gnus-method-to-server method)))
(equal server
(gnus-method-to-server method nil t)))
(setq match method
alist nil)))
match))))
(when result
(when (and result
(not (assoc server gnus-server-method-cache)))
(push (cons server result) gnus-server-method-cache))
result)))

144
lisp/gnus/nnimap.el
View File

@ -62,11 +62,6 @@ Values are `ssl' and `network'.")
(defvoo nnimap-inbox nil
"The mail box where incoming mail arrives and should be split out of.")
(defvoo nnimap-expunge-inbox nil
"If non-nil, expunge the inbox after fetching mail.
This is always done if the server supports UID EXPUNGE, but it's
not done by default on servers that doesn't support that command.")
(defvoo nnimap-authenticator nil
"How nnimap authenticate itself to the server.
Possible choices are nil (use default methods) or `anonymous'.")
@ -78,7 +73,11 @@ will fetch all parts that have types that match that string. A
likely value would be \"text/\" to automatically fetch all
textual parts.")
(defvoo nnimap-expunge nil)
(defvoo nnimap-expunge t
"If non-nil, expunge articles after deleting them.
This is always done if the server supports UID EXPUNGE, but it's
not done by default on servers that doesn't support that command.")
(defvoo nnimap-connection-alist nil)
@ -92,14 +91,14 @@ textual parts.")
"Internal variable with default value for `nnimap-split-download-body'.")
(defstruct nnimap
group process commands capabilities select-result newlinep)
group process commands capabilities select-result newlinep server)
(defvar nnimap-object nil)
(defvar nnimap-mark-alist
'((read "\\Seen")
(tick "\\Flagged")
(reply "\\Answered")
'((read "\\Seen" %Seen)
(tick "\\Flagged" %Flagged)
(reply "\\Answered" %Answered)
(expire "gnus-expire")
(dormant "gnus-dormant")
(score "gnus-score")
@ -213,7 +212,8 @@ textual parts.")
(buffer-disable-undo)
(gnus-add-buffer)
(set (make-local-variable 'after-change-functions) nil)
(set (make-local-variable 'nnimap-object) (make-nnimap))
(set (make-local-variable 'nnimap-object)
(make-nnimap :server (nnoo-current-server 'nnimap)))
(push (list buffer (current-buffer)) nnimap-connection-alist)
(current-buffer)))
@ -421,8 +421,9 @@ textual parts.")
(goto-char (point-max))
(cond
(marks
(setq high (nth 3 (car marks))
low (nth 4 (car marks))))
(let ((uidnext (nth 5 (car marks))))
(setq high (or (nth 3 (car marks)) (1- uidnext))
low (or (nth 4 (car marks)) uidnext))))
((re-search-backward "UIDNEXT \\([0-9]+\\)" nil t)
(setq high (1- (string-to-number (match-string 1)))
low 1)))))
@ -502,7 +503,8 @@ textual parts.")
nil)
(t
(let ((deletable-articles
(if force
(if (or force
(eq nnmail-expiry-wait 'immediate))
articles
(gnus-sorted-intersection
articles
@ -587,9 +589,9 @@ textual parts.")
(deffoo nnimap-request-scan (&optional group server)
(when (and (nnimap-possibly-change-group nil server)
(equal group nnimap-inbox)
nnimap-inbox
nnimap-split-methods)
(message "nnimap %s splitting mail..." server)
(nnimap-split-incoming-mail)))
(defun nnimap-marks-to-flags (marks)
@ -667,6 +669,7 @@ textual parts.")
sequences responses)
(when groups
(with-current-buffer (nnimap-buffer)
(setf (nnimap-group nnimap-object) nil)
(dolist (group groups)
(push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t))
group)
@ -716,6 +719,7 @@ textual parts.")
groups))
;; Then request the data.
(erase-buffer)
(setf (nnimap-group nnimap-object) nil)
(dolist (elem groups)
(if (and qresyncp
(nth 2 elem))
@ -773,7 +777,8 @@ textual parts.")
(defun nnimap-update-info (info marks)
(when marks
(destructuring-bind (existing flags high low uidnext start-article) marks
(destructuring-bind (existing flags high low uidnext start-article
permanent-flags) marks
(let ((group (gnus-info-group info))
(completep (and start-article
(= start-article 1))))
@ -784,16 +789,18 @@ textual parts.")
(if high
(cons low high)
;; No articles in this group.
(cons (1- uidnext) uidnext)))
(setcdr (gnus-active group) high))
(cons uidnext (1- uidnext))))
(setcdr (gnus-active group) (or high (1- uidnext))))
(unless high
(setq high (1- uidnext)))
;; Then update the list of read articles.
(let* ((unread
(gnus-compress-sequence
(gnus-set-difference
(gnus-set-difference
existing
(cdr (assoc "\\Seen" flags)))
(cdr (assoc "\\Flagged" flags)))))
(cdr (assoc '%Seen flags)))
(cdr (assoc '%Flagged flags)))))
(read (gnus-range-difference
(cons start-article high) unread)))
(when (> start-article 1)
@ -815,8 +822,10 @@ textual parts.")
(push (cons 'active (gnus-active group)) marks)))
(dolist (type (cdr nnimap-mark-alist))
(let ((old-marks (assoc (car type) marks))
(new-marks (gnus-compress-sequence
(cdr (assoc (cadr type) flags)))))
(new-marks
(gnus-compress-sequence
(cdr (or (assoc (caddr type) flags) ; %Flagged
(assoc (cadr type) flags)))))) ; "\Flagged"
(setq marks (delq old-marks marks))
(pop old-marks)
(when (and old-marks
@ -838,12 +847,13 @@ textual parts.")
(push (list group info active) nnimap-current-infos))))
(defun nnimap-flags-to-marks (groups)
(let (data group totalp uidnext articles start-article mark)
(let (data group totalp uidnext articles start-article mark permanent-flags)
(dolist (elem groups)
(setq group (car elem)
uidnext (cadr elem)
start-article (caddr elem)
articles (cdddr elem))
uidnext (nth 1 elem)
start-article (nth 2 elem)
permanent-flags (nth 3 elem)
articles (nthcdr 4 elem))
(let ((high (caar articles))
marks low existing)
(dolist (article articles)
@ -853,36 +863,49 @@ textual parts.")
(setq mark (assoc flag marks))
(if (not mark)
(push (list flag (car article)) marks)
(setcdr mark (cons (car article) (cdr mark)))))
(push (list group existing marks high low uidnext start-article)
data))))
(setcdr mark (cons (car article) (cdr mark))))))
(push (list group existing marks high low uidnext start-article
permanent-flags)
data)))
data))
(defun nnimap-parse-flags (sequences)
(goto-char (point-min))
(let (start end articles groups uidnext elems)
;; Change \Delete etc to %Delete, so that the reader can read it.
(subst-char-in-region (point-min) (point-max)
?\\ ?% t)
(let (start end articles groups uidnext elems permanent-flags)
(dolist (elem sequences)
(destructuring-bind (group-sequence flag-sequence totalp group) elem
(setq start (point))
;; The EXAMINE was successful.
(when (and (search-forward (format "\n%d OK " group-sequence) nil t)
(progn
(forward-line 1)
(setq start (point))
(if (re-search-backward "UIDNEXT \\([0-9]+\\)"
(or end (point-min)) t)
(setq uidnext (string-to-number (match-string 1)))
(setq uidnext nil))
(goto-char start))
(setq end (point))
(goto-char start)
(setq permanent-flags
(and (search-forward "PERMANENTFLAGS "
(or end (point-min)) t)
(read (current-buffer))))
(goto-char start)
(setq uidnext
(and (search-forward "UIDNEXT "
(or end (point-min)) t)
(read (current-buffer))))
(goto-char end)
(forward-line -1))
;; The UID FETCH FLAGS was successful.
(search-forward (format "\n%d OK " flag-sequence) nil t))
(setq end (point))
(goto-char start)
(while (re-search-forward "^\\* [0-9]+ FETCH (\\(.*\\))" end t)
(setq elems (nnimap-parse-line (match-string 1)))
(push (cons (string-to-number (cadr (member "UID" elems)))
(cadr (member "FLAGS" elems)))
(setq start (point))
(goto-char end)
(while (search-forward " FETCH " start t)
(setq elems (read (current-buffer)))
(push (cons (cadr (memq 'UID elems))
(cadr (memq 'FLAGS elems)))
articles))
(push (nconc (list group uidnext totalp) articles) groups)
(push (nconc (list group uidnext totalp permanent-flags) articles)
groups)
(setq articles nil))))
groups))
@ -1085,32 +1108,38 @@ textual parts.")
(nnmail-split-incoming (current-buffer)
#'nnimap-save-mail-spec
nil nil
#'nnimap-dummy-active-number)
#'nnimap-dummy-active-number
#'nnimap-save-mail-spec)
(when nnimap-incoming-split-list
(let ((specs (nnimap-make-split-specs nnimap-incoming-split-list))
sequences)
sequences junk-articles)
;; Create any groups that doesn't already exist on the
;; server first.
(dolist (spec specs)
(unless (member (car spec) groups)
(when (and (not (member (car spec) groups))
(not (eq (car spec) 'junk)))
(nnimap-command "CREATE %S" (utf7-encode (car spec) t))))
;; Then copy over all the messages.
(erase-buffer)
(dolist (spec specs)
(let ((group (car spec))
(ranges (cdr spec)))
(push (list (nnimap-send-command "UID COPY %s %S"
(nnimap-article-ranges ranges)
(utf7-encode group t))
ranges)
sequences)))
(if (eq group 'junk)
(setq junk-articles ranges)
(push (list (nnimap-send-command
"UID COPY %s %S"
(nnimap-article-ranges ranges)
(utf7-encode group t))
ranges)
sequences))))
;; Wait for the last COPY response...
(when sequences
(nnimap-wait-for-response (caar sequences))
;; And then mark the successful copy actions as deleted,
;; and possibly expunge them.
(nnimap-mark-and-expunge-incoming
(nnimap-parse-copied-articles sequences)))))))))
(nnimap-parse-copied-articles sequences))
(nnimap-mark-and-expunge-incoming junk-articles))))))))
(defun nnimap-mark-and-expunge-incoming (range)
(when range
@ -1125,7 +1154,7 @@ textual parts.")
(setq sequence (nnimap-send-command "UID EXPUNGE %s" range)))
;; If it doesn't support UID EXPUNGE, then we only expunge if the
;; user has configured it.
(nnimap-expunge-inbox
(nnimap-expunge
(setq sequence (nnimap-send-command "EXPUNGE"))))
(nnimap-wait-for-response sequence))))
@ -1142,8 +1171,8 @@ textual parts.")
(let (new)
(dolist (elem flags)
(when (or (null (cdr elem))
(and (not (member "\\Deleted" (cdr elem)))
(not (member "\\Seen" (cdr elem)))))
(and (not (memq '%Deleted (cdr elem)))
(not (memq '%Seen (cdr elem)))))
(push (car elem) new)))
(gnus-compress-sequence (nreverse new))))
@ -1190,7 +1219,10 @@ textual parts.")
(if (not (re-search-forward "X-nnimap-article: \\([0-9]+\\)" nil t))
(error "Invalid nnimap mail")
(setq article (string-to-number (match-string 1))))
(push (list article group-art)
(push (list article
(if (eq group-art 'junk)
(list (cons 'junk 1))
group-art))
nnimap-incoming-split-list)))
(provide 'nnimap)

24
lisp/gnus/nnmail.el
View File

@ -963,7 +963,7 @@ If SOURCE is a directory spec, try to return the group name component."
(goto-char end)))
count))
(defun nnmail-process-mmdf-mail-format (func artnum-func)
(defun nnmail-process-mmdf-mail-format (func artnum-func &optional junk-func)
(let ((delim "^\^A\^A\^A\^A$")
(case-fold-search t)
(count 0)
@ -1011,7 +1011,7 @@ If SOURCE is a directory spec, try to return the group name component."
(narrow-to-region start (point))
(goto-char (point-min))
(incf count)
(nnmail-check-duplication message-id func artnum-func)
(nnmail-check-duplication message-id func artnum-func junk-func)
(setq end (point-max))))
(goto-char end)
(forward-line 2)))
@ -1056,7 +1056,7 @@ If SOURCE is a directory spec, try to return the group name component."
"Non-nil means group names are not encoded.")
(defun nnmail-split-incoming (incoming func &optional exit-func
group artnum-func)
group artnum-func junk-func)
"Go through the entire INCOMING file and pick out each individual mail.
FUNC will be called with the buffer narrowed to each mail.
INCOMING can also be a buffer object. In that case, the mail
@ -1087,7 +1087,8 @@ will be copied over from that buffer."
(looking-at "BABYL OPTIONS:"))
(nnmail-process-babyl-mail-format func artnum-func))
((looking-at "\^A\^A\^A\^A")
(nnmail-process-mmdf-mail-format func artnum-func))
(nnmail-process-mmdf-mail-format
func artnum-func junk-func))
((looking-at "Return-Path:")
(nnmail-process-maildir-mail-format func artnum-func))
(t
@ -1096,7 +1097,7 @@ will be copied over from that buffer."
(funcall exit-func))
(kill-buffer (current-buffer))))))
(defun nnmail-article-group (func &optional trace)
(defun nnmail-article-group (func &optional trace junk-func)
"Look at the headers and return an alist of groups that match.
FUNC will be called with the group name to determine the article number."
(let ((methods (or nnmail-split-methods '(("bogus" ""))))
@ -1163,9 +1164,10 @@ FUNC will be called with the group name to determine the article number."
;; The article may be "cross-posted" to `junk'. What
;; to do? Just remove the `junk' spec. Don't really
;; see anything else to do...
(let (elem)
(while (setq elem (car (memq 'junk split)))
(setq split (delq elem split))))
(when (and (memq 'junk split)
junk-func)
(funcall junk-func 'junk))
(setq split (delq 'junk split))
(when split
(setq group-art
(mapcar
@ -1714,7 +1716,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(message-narrow-to-head)
(message-fetch-field header))))
(defun nnmail-check-duplication (message-id func artnum-func)
(defun nnmail-check-duplication (message-id func artnum-func
&optional junk-func)
(run-hooks 'nnmail-prepare-incoming-message-hook)
;; If this is a duplicate message, then we do not save it.
(let* ((duplication (nnmail-cache-id-exists-p message-id))
@ -1739,7 +1742,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
(cond
((not duplication)
(funcall func (setq group-art
(nreverse (nnmail-article-group artnum-func))))
(nreverse (nnmail-article-group
artnum-func nil junk-func))))
(nnmail-cache-insert message-id (caar group-art)))
((eq action 'delete)
(setq group-art nil))