Mercurial > emacs
changeset 111705:cad125981c0f
Merge changes made in Gnus trunk.
shr-color.el (shr-color-visible): Really return original background if fixed.
shr.el (shr-insert-color-overlay): Replace deprecated syntax.
shr.el (shr-tag-body, shr-descend): Add background support.
shr.el (shr-tag-title): Add.
gnus-sum.el (gnus-summary-articles-in-thread): Fix a bug that causes this function to return incorrect results.
shr.el (shr-parse-style): Drop !important from styles.
message.el (message-goto-body): Remove the <#secure special-casing, which is too special.
mm-util.el (mm-enable-multibyte): Use `to' instead of t. This fixes something or other in Emacs 23, and is backwards compatible.
message.el (message-goto-body): Use called-interactively-p.
message.el (message-in-body-p): message-goto-body returns point.
nnimap.el (nnimap-request-move-article): It's no longer necessary to clear marks before moving, since they're synced from the Gnus side first.
gnus-sum.el (gnus-summary-push-marks-to-backend): New function.
gnus-sum.el (gnus-summary-move-article): Copy over all marks before moving, so that IMAP doesn't think a new article has arrived.
message.el (message-goto-body): called-interactively-p needs a parameter, so use `any'.
gnus-cache.el (gnus-summary-insert-cached-articles): Use it.
gnus-sum.el (gnus-summary-include-articles): New function.
shr.el (shr-tag-table, shr-render-td): Add bgcolor support.
shr-color.el (shr-color-visible): Fix docstring.
shr.el (shr-insert-background-overlay): Fix typo.
shr.el (shr-render-td): Copy the background before rendering.
| author | Katsumi Yamaoka <yamaoka@jpl.org> |
|---|---|
| date | Wed, 24 Nov 2010 22:54:47 +0000 |
| parents | 31c8556ccad8 |
| children | aa78024b0867 |
| files | lisp/gnus/ChangeLog lisp/gnus/gnus-cache.el lisp/gnus/gnus-sum.el lisp/gnus/message.el lisp/gnus/mm-util.el lisp/gnus/nnimap.el lisp/gnus/shr-color.el lisp/gnus/shr.el |
| diffstat | 8 files changed, 226 insertions(+), 70 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/gnus/ChangeLog Wed Nov 24 11:39:51 2010 -0500 +++ b/lisp/gnus/ChangeLog Wed Nov 24 22:54:47 2010 +0000 @@ -1,3 +1,62 @@ +2010-11-24 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-cache.el (gnus-summary-insert-cached-articles): Use it. + + * gnus-sum.el (gnus-summary-include-articles): New function. + + * message.el (message-goto-body): called-interactively-p needs a + parameter, so use `any'. + + * nnimap.el (nnimap-request-move-article): It's no longer necessary to + clear marks before moving, since they're synced from the Gnus side + first. + + * gnus-sum.el (gnus-summary-push-marks-to-backend): New function. + (gnus-summary-move-article): Copy over all marks before moving, so that + IMAP doesn't think a new article has arrived. + +2010-11-24 Julien Danjou <julien@danjou.info> + + * shr.el (shr-insert-background-overlay): Fix typo. + (shr-render-td): Copy the background before rendering. + + * shr-color.el (shr-color-visible): Fix docstring. + + * shr.el (shr-tag-table): Add bgcolor support. + (shr-render-td): Add bgcolor support. + (shr-get-background): Add. + (shr-insert-foreground-overlay): Use shr-get-background. + + * message.el (message-goto-body): Use called-interactively-p. + (message-in-body-p): message-goto-body returns point. + +2010-11-24 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * mm-util.el (mm-enable-multibyte): Use `to' instead of t. This fixes + Fixes something or other in Emacs 23, and is backwards compatible. + + * message.el (message-goto-body): Remove the <#secure special-casing, + which is too special. + + * shr.el (shr-parse-style): Drop !important from styles. + +2010-11-24 Daniel Schoepe <daniel.schoepe@googlemail.com> (tiny change) + + * gnus-sum.el (gnus-summary-articles-in-thread): Fix a bug that causes + this function to return incorrect results when calling it with an + explicit article argument different from + (gnus-summary-article-number). + +2010-11-24 Julien Danjou <julien@danjou.info> + + * shr.el (shr-insert-color-overlay): Replace deprecated syntax. + (shr-tag-body): Add background support. + (shr-descend): Add background support. + (shr-tag-title): Add. + + * shr-color.el (shr-color-visible): Really return original background + if fixed. + 2010-11-24 Lars Magne Ingebrigtsen <larsi@gnus.org> * shr.el (shr-color-check): Protect against non-existant colour names. @@ -46,7 +105,8 @@ * shr.el (shr-parse-style): Replace \n with space in style parsing. - * shr-color.el (shr-color-hsl-to-rgb-fractions): Use shr-color-hue-to-rgb. + * shr-color.el (shr-color-hsl-to-rgb-fractions): Use + shr-color-hue-to-rgb. (shr-color->hexadecimal): Call shr-color-hsl-to-rgb-fractions. 2010-11-23 Lars Magne Ingebrigtsen <larsi@gnus.org>
--- a/lisp/gnus/gnus-cache.el Wed Nov 24 11:39:51 2010 -0500 +++ b/lisp/gnus/gnus-cache.el Wed Nov 24 22:54:47 2010 +0000 @@ -383,9 +383,14 @@ "Insert all the articles cached for this group into the current buffer." (interactive) (let ((gnus-verbose (max 6 gnus-verbose))) - (if (not gnus-newsgroup-cached) - (gnus-message 3 "No cached articles for this group") - (gnus-summary-goto-subjects gnus-newsgroup-cached)))) + (cond + ((not gnus-newsgroup-cached) + (gnus-message 3 "No cached articles for this group")) + ;; This is faster if there are few articles to insert. + ((< (length gnus-newsgroup-cached) 20) + (gnus-summary-goto-subjects gnus-newsgroup-cached)) + (t + (gnus-summary-include-articles gnus-newsgroup-cached))))) (defun gnus-summary-limit-include-cached () "Limit the summary buffer to articles that are cached."
--- a/lisp/gnus/gnus-sum.el Wed Nov 24 11:39:51 2010 -0500 +++ b/lisp/gnus/gnus-sum.el Wed Nov 24 22:54:47 2010 +0000 @@ -8500,6 +8500,18 @@ (gnus-summary-limit (append gnus-newsgroup-dormant gnus-newsgroup-limit)) (gnus-summary-position-point))) +(defun gnus-summary-include-articles (articles) + "Fetch the headers for ARTICLES and then display the summary lines." + (let ((gnus-inhibit-demon t) + (gnus-agent nil) + (gnus-read-all-available-headers t)) + (setq gnus-newsgroup-headers + (gnus-merge + 'list gnus-newsgroup-headers + (gnus-fetch-headers articles nil t) + 'gnus-article-sort-by-number)) + (gnus-summary-limit (append articles gnus-newsgroup-limit)))) + (defun gnus-summary-limit-exclude-dormant () "Hide all dormant articles." (interactive) @@ -9705,6 +9717,9 @@ articles) (while articles (setq article (pop articles)) + ;; Set any marks that may have changed in the summary buffer. + (when gnus-preserve-marks + (gnus-summary-push-marks-to-backend article)) (let ((gnus-newsgroup-original-name gnus-newsgroup-name) (gnus-article-original-subject (mail-header-subject @@ -9921,6 +9936,25 @@ (gnus-summary-position-point) (gnus-set-mode-line 'summary))) +(defun gnus-summary-push-marks-to-backend (article) + (let ((add nil) + (delete nil) + (marks gnus-article-mark-lists)) + (if (memq article gnus-newsgroup-unreads) + (push 'read add) + (push 'read delete)) + (while marks + (when (eq (gnus-article-mark-to-type (cdar marks)) 'list) + (if (memq article (symbol-value + (intern (format "gnus-newsgroup-%s" + (caar marks))))) + (push (cdar marks) add) + (push (cdar marks) delete))) + (pop marks)) + (gnus-request-set-mark gnus-newsgroup-name + `(((,article) add ,add) + ((,article) del ,delete))))) + (defun gnus-summary-copy-article (&optional n to-newsgroup select-method) "Copy the current article to some other group. If TO-NEWSGROUP is string, do not prompt for a newsgroup to copy to. @@ -11232,6 +11266,7 @@ (mail-header-subject (gnus-data-header (car data))))) (t nil))) (end-point (save-excursion + (goto-char (gnus-data-pos (car data))) (if (gnus-summary-go-to-next-thread) (point) (point-max)))) articles)
--- a/lisp/gnus/message.el Wed Nov 24 11:39:51 2010 -0500 +++ b/lisp/gnus/message.el Wed Nov 24 22:54:47 2010 +0000 @@ -3047,10 +3047,10 @@ (interactive) (message-position-on-field "Summary" "Subject")) -(defun message-goto-body (&optional interactivep) +(defun message-goto-body () "Move point to the beginning of the message body." - (interactive (list t)) - (when (and interactivep + (interactive) + (when (and (called-interactively-p 'any) (looking-at "[ \t]*\n")) (expand-abbrev)) (goto-char (point-min)) @@ -3059,7 +3059,7 @@ (defun message-in-body-p () "Return t if point is in the message body." - (let ((body (save-excursion (message-goto-body) (point)))) + (let ((body (save-excursion (message-goto-body)))) (>= (point) body))) (defun message-goto-eoh ()
--- a/lisp/gnus/mm-util.el Wed Nov 24 11:39:51 2010 -0500 +++ b/lisp/gnus/mm-util.el Wed Nov 24 22:54:47 2010 +0000 @@ -903,7 +903,7 @@ "Set the multibyte flag of the current buffer. Only do this if the default value of `enable-multibyte-characters' is non-nil. This is a no-op in XEmacs." - (set-buffer-multibyte t))) + (set-buffer-multibyte 'to))) (if (featurep 'xemacs) (defalias 'mm-disable-multibyte 'ignore)
--- a/lisp/gnus/nnimap.el Wed Nov 24 11:39:51 2010 -0500 +++ b/lisp/gnus/nnimap.el Wed Nov 24 22:54:47 2010 +0000 @@ -783,9 +783,6 @@ (if internal-move-group (let ((result (with-current-buffer (nnimap-buffer) - ;; Clear all flags before moving. - (nnimap-send-command "UID STORE %d FLAGS.SILENT ()" - article) (nnimap-command "UID COPY %d %S" article (utf7-encode internal-move-group t)))))
--- a/lisp/gnus/shr-color.el Wed Nov 24 11:39:51 2010 -0500 +++ b/lisp/gnus/shr-color.el Wed Nov 24 22:54:47 2010 +0000 @@ -318,8 +318,8 @@ (defun shr-color-visible (bg fg &optional fixed-background) "Check that BG and FG colors are visible if they are drawn on each other. -Return t if they are. If they are too similar, two new colors are -returned instead. +Return (bg fg) if they are. If they are too similar, two new +colors are returned instead. If FIXED-BACKGROUND is set, and if the color are not visible, a new background color will not be computed. Only the foreground color will be adapted to be visible on BG." @@ -337,11 +337,14 @@ (let ((Ls (set-minimum-interval (car bg-lab) (car fg-lab) 0 100 shr-color-visible-luminance-min fixed-background))) - (setcar bg-lab (car Ls)) + (unless fixed-background + (setcar bg-lab (car Ls))) (setcar fg-lab (cadr Ls)) (list - (apply 'format "#%02x%02x%02x" - (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) (apply 'lab->rgb bg-lab))) + (if fixed-background + bg + (apply 'format "#%02x%02x%02x" + (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) (apply 'lab->rgb bg-lab)))) (apply 'format "#%02x%02x%02x" (mapcar (lambda (x) (* (max (min 1 x) 0) 255)) (apply 'lab->rgb fg-lab))))))))
--- a/lisp/gnus/shr.el Wed Nov 24 11:39:51 2010 -0500 +++ b/lisp/gnus/shr.el Wed Nov 24 22:54:47 2010 +0000 @@ -201,7 +201,10 @@ (funcall function (cdr dom)) (shr-generic (cdr dom))) (when (consp style) - (shr-insert-color-overlay (cdr (assq 'color style)) start (point))))) + (shr-insert-background-overlay (cdr (assq 'background-color style)) + start) + (shr-insert-foreground-overlay (cdr (assq 'color style)) + start (point))))) (defun shr-generic (cont) (dolist (sub cont) @@ -494,23 +497,65 @@ (autoload 'shr-color-visible "shr-color") (autoload 'shr-color->hexadecimal "shr-color") -(defun shr-color-check (fg &optional bg) - "Check that FG is visible on BG." - (let ((hex-color (shr-color->hexadecimal fg))) - (when hex-color - (shr-color-visible (or (shr-color->hexadecimal bg) - (frame-parameter nil 'background-color)) - hex-color (not bg))))) + +(defun shr-color-check (fg bg) + "Check that FG is visible on BG. +Returns (fg bg) with corrected values. +Returns nil if the colors that would be used are the default +ones, in case fg and bg are nil." + (when (or fg bg) + (let ((fixed (cond ((null fg) 'fg) + ((null bg) 'bg)))) + ;; Convert colors to hexadecimal, or set them to default. + (let ((fg (or (shr-color->hexadecimal fg) + (frame-parameter nil 'foreground-color))) + (bg (or (shr-color->hexadecimal bg) + (frame-parameter nil 'background-color)))) + (cond ((eq fixed 'bg) + ;; Only return the new fg + (list nil (cadr (shr-color-visible bg fg t)))) + ((eq fixed 'fg) + ;; Invert args and results and return only the new bg + (list (cadr (shr-color-visible fg bg t)) nil)) + (t + (shr-color-visible bg fg))))))) -(defun shr-insert-color-overlay (color start end) - (when color - (let ((new-color (cadr (shr-color-check color)))) - (when new-color - (overlay-put (make-overlay start end) 'face - (cons 'foreground-color new-color)))))) +(defun shr-get-background (pos) + "Return background color at POS." + (dolist (overlay (overlays-in start (1+ start))) + (let ((background (plist-get (overlay-get overlay 'face) + :background))) + (when background + (return background))))) + +(defun shr-insert-foreground-overlay (fg start end) + (when fg + (let ((bg (shr-get-background start))) + (let ((new-colors (shr-color-check fg bg))) + (when new-colors + (overlay-put (make-overlay start end) 'face + (list :foreground (cadr new-colors)))))))) + +(defun shr-insert-background-overlay (bg start) + "Insert an overlay with background color BG at START. +The overlay has rear-advance set to t, so it will be used when +text will be inserted at start." + (when bg + (let ((new-colors (shr-color-check nil bg))) + (when new-colors + (overlay-put (make-overlay start start nil nil t) 'face + (list :background (car new-colors))))))) ;;; Tag-specific rendering rules. +(defun shr-tag-body (cont) + (let ((start (point)) + (fgcolor (cdr (assq :fgcolor cont))) + (bgcolor (cdr (assq :bgcolor cont)))) + (shr-insert-background-overlay bgcolor start) + (shr-generic cont) + (shr-insert-foreground-overlay fgcolor start (point)))) + (defun shr-tag-p (cont) (shr-ensure-paragraph) (shr-indent) @@ -554,6 +599,8 @@ (cadr elem)) (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem))) (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem)))) + (when (string-match " *!important\\'" value) + (setq value (substring value 0 (match-beginning 0)))) (push (cons (intern name obarray) value) plist))))) @@ -703,11 +750,14 @@ (shr-ensure-newline) (insert (make-string shr-width shr-hr-line) "\n")) +(defun shr-tag-title (cont) + (shr-heading cont 'bold 'underline)) + (defun shr-tag-font (cont) (let ((start (point)) (color (cdr (assq :color cont)))) (shr-generic cont) - (shr-insert-color-overlay color start (point)))) + (shr-insert-foreground-overlay color start (point)))) ;;; Table rendering algorithm. @@ -755,9 +805,11 @@ (header (cdr (assq 'thead cont))) (body (or (cdr (assq 'tbody cont)) cont)) (footer (cdr (assq 'tfoot cont))) + (bgcolor (cdr (assq :bgcolor cont))) (nheader (if header (shr-max-columns header))) (nbody (if body (shr-max-columns body))) (nfooter (if footer (shr-max-columns footer)))) + (shr-insert-background-overlay bgcolor (point)) (shr-tag-table-1 (nconc (if caption `((tr (td ,@caption)))) @@ -900,44 +952,48 @@ (nreverse trs))) (defun shr-render-td (cont width fill) - (with-temp-buffer - (let ((cache (cdr (assoc (cons width cont) shr-content-cache)))) - (if cache - (insert cache) - (let ((shr-width width) - (shr-indentation 0)) - (shr-generic cont)) - (delete-region - (point) - (+ (point) - (skip-chars-backward " \t\n"))) - (push (cons (cons width cont) (buffer-string)) - shr-content-cache))) - (goto-char (point-min)) - (let ((max 0)) - (while (not (eobp)) - (end-of-line) - (setq max (max max (current-column))) - (forward-line 1)) - (when fill - (goto-char (point-min)) - ;; If the buffer is totally empty, then put a single blank - ;; line here. - (if (zerop (buffer-size)) - (insert (make-string width ? )) - ;; Otherwise, fill the buffer. - (while (not (eobp)) - (end-of-line) - (when (> (- width (current-column)) 0) - (insert (make-string (- width (current-column)) ? ))) - (forward-line 1)))) - (if fill - (list max - (count-lines (point-min) (point-max)) - (split-string (buffer-string) "\n") - (shr-collect-overlays)) - (list max - (shr-natural-width)))))) + (let ((background (shr-get-background (point)))) + (with-temp-buffer + (let ((cache (cdr (assoc (cons width cont) shr-content-cache)))) + (if cache + (insert cache) + (shr-insert-background-overlay (or (cdr (assq :bgcolor cont)) + background) + (point)) + (let ((shr-width width) + (shr-indentation 0)) + (shr-generic cont)) + (delete-region + (point) + (+ (point) + (skip-chars-backward " \t\n"))) + (push (cons (cons width cont) (buffer-string)) + shr-content-cache))) + (goto-char (point-min)) + (let ((max 0)) + (while (not (eobp)) + (end-of-line) + (setq max (max max (current-column))) + (forward-line 1)) + (when fill + (goto-char (point-min)) + ;; If the buffer is totally empty, then put a single blank + ;; line here. + (if (zerop (buffer-size)) + (insert (make-string width ? )) + ;; Otherwise, fill the buffer. + (while (not (eobp)) + (end-of-line) + (when (> (- width (current-column)) 0) + (insert (make-string (- width (current-column)) ? ))) + (forward-line 1)))) + (if fill + (list max + (count-lines (point-min) (point-max)) + (split-string (buffer-string) "\n") + (shr-collect-overlays)) + (list max + (shr-natural-width))))))) (defun shr-natural-width () (goto-char (point-min))