[Emacs-diffs] /srv/bzr/emacs/trunk r102505: Merge changes made in Gnus trunk.

[Katsumi Yamaoka]

------------------------------------------------------------
revno: 102505
author: Gnus developers
committer: Katsumi Yamaoka <address@hidden>
branch nick: trunk
timestamp: Wed 2010-11-24 22:54:47 +0000
message:
  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.
modified:
  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

=== modified file 'lisp/gnus/ChangeLog'
--- a/lisp/gnus/ChangeLog       2010-11-24 12:56:50 +0000
+++ b/lisp/gnus/ChangeLog       2010-11-24 22:54:47 +0000
@@ -1,5 +1,64 @@
 2010-11-24  Lars Magne Ingebrigtsen  <address@hidden>
 
+       * 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  <address@hidden>
+
+       * 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  <address@hidden>
+
+       * 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  <address@hidden>  (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  <address@hidden>
+
+       * 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  <address@hidden>
+
        * shr.el (shr-color-check): Protect against non-existant colour names.
 
 2010-11-24  Julien Danjou  <address@hidden>
@@ -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  <address@hidden>

=== modified file 'lisp/gnus/gnus-cache.el'
--- a/lisp/gnus/gnus-cache.el   2010-10-11 23:29:33 +0000
+++ b/lisp/gnus/gnus-cache.el   2010-11-24 22:54:47 +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."

=== modified file 'lisp/gnus/gnus-sum.el'
--- a/lisp/gnus/gnus-sum.el     2010-11-15 23:45:55 +0000
+++ b/lisp/gnus/gnus-sum.el     2010-11-24 22:54:47 +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)

=== modified file 'lisp/gnus/message.el'
--- a/lisp/gnus/message.el      2010-11-10 23:16:01 +0000
+++ b/lisp/gnus/message.el      2010-11-24 22:54:47 +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 ()

=== modified file 'lisp/gnus/mm-util.el'
--- a/lisp/gnus/mm-util.el      2010-11-01 06:39:01 +0000
+++ b/lisp/gnus/mm-util.el      2010-11-24 22:54:47 +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)

=== modified file 'lisp/gnus/nnimap.el'
--- a/lisp/gnus/nnimap.el       2010-11-21 22:46:16 +0000
+++ b/lisp/gnus/nnimap.el       2010-11-24 22:54:47 +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)))))

=== modified file 'lisp/gnus/shr-color.el'
--- a/lisp/gnus/shr-color.el    2010-11-24 11:32:22 +0000
+++ b/lisp/gnus/shr-color.el    2010-11-24 22:54:47 +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))))))))
 

=== modified file 'lisp/gnus/shr.el'
--- a/lisp/gnus/shr.el  2010-11-24 11:32:22 +0000
+++ b/lisp/gnus/shr.el  2010-11-24 22:54:47 +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-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-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-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))