diff lisp/gnus/shr.el @ 111830:79219ca01c7b

Merge changes made in Gnus trunk. nnir.el (nnir-categorize): Replace mapcar with mapc. shr.el (shr-urlify): Display the title in <a> tags. shr.el (shr-urlify): Show the URL before the title to avoid misleading URLs. gnus-sum.el (gnus-summary-show-article): Reverse the meanings of `C-u C-u g' and `C-u g' so that `C-u g' does what it traditionally did. gnus.texi (Paging the Article): Note the reverse meanings of `C-u C-u g'. gnus-html.el (gnus-html-put-image): Use widget instead of local maps so that TAB works. nnir.el (nnir-run-gmane): Use more careful test for gmane nntp server. nnimap.el (nnimap-process-expiry-targets): Avoid downloading articles unless necessary. gnus-util.el (gnus-output-to-mail): Require nnmail before using nnmail variables. shr.el (shr-stylesheet): New dynamic variable for cascading the styles. (shr-colorize-region): New function. (shr-insert-background-overlay): Remove. (shr-render-td): Background setting should be taken care of on a higher level. (shr-tag-body): Use post-hoc colorizations. (shr-descend): Only render color/background when they change. (shr-tag-body): Set up a style sheet based on bgcolor/fgcolor. (shr-put-color-1): Don't overwrite old colors. (shr-colorize-region): When the background color isn't explicit, use a fixed background. gnus.el (gnus-valid-select-methods): Allow nnimap to respool. nntp.el (nntp-snarf-error-message): nnheader-report takes a format string as the parameter. gnus-sum.el (gnus-summary-respool-article): The completion function expects a list instead of an alist.

--- a/lisp/gnus/shr.el	Sat Dec 04 20:23:22 2010 -0500
+++ b/lisp/gnus/shr.el	Sun Dec 05 22:17:34 2010 +0000
@@ -94,6 +94,7 @@
 (defvar shr-content-cache nil)
 (defvar shr-kinsoku-shorten nil)
 (defvar shr-table-depth 0)
+(defvar shr-stylesheet nil)
 
 (defvar shr-map
   (let ((map (make-sparse-keymap)))
@@ -191,18 +192,21 @@
 (defun shr-descend (dom)
   (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))
 	(style (cdr (assq :style (cdr dom))))
+	(shr-stylesheet shr-stylesheet)
 	(start (point)))
     (when (and style
 	       (string-match "color" style))
-      (setq style (shr-parse-style style)))
+      (setq shr-stylesheet (nconc (shr-parse-style style)
+				  shr-stylesheet)))
     (if (fboundp function)
 	(funcall function (cdr dom))
       (shr-generic (cdr dom)))
-    (when (consp style)
-      (shr-insert-background-overlay (cdr (assq 'background-color style))
-                                     start)
-      (shr-insert-foreground-overlay (cdr (assq 'color style))
-                                     start (point)))))
+    (let ((color (cdr (assq 'color shr-stylesheet)))
+	  (background (cdr (assq 'background-color
+				 shr-stylesheet))))
+      (when (and shr-stylesheet
+		 (or color background))
+	(shr-colorize-region start (point) color background)))))
 
 (defun shr-generic (cont)
   (dolist (sub cont)
@@ -544,10 +548,10 @@
 
 (autoload 'widget-convert-button "wid-edit")
 
-(defun shr-urlify (start url)
+(defun shr-urlify (start url &optional title)
   (widget-convert-button
    'url-link start (point)
-   :help-echo url
+   :help-echo (if title (format "%s (%s)" url title) url)
    :keymap shr-map
    url)
   (put-text-property start (point) 'shr-url url))
@@ -581,41 +585,58 @@
               (t
                (shr-color-visible bg fg)))))))
 
-(defun shr-get-background (pos)
-  "Return background color at POS."
-  (dolist (overlay (overlays-in pos (1+ pos)))
-    (let ((background (plist-get (overlay-get overlay 'face)
-                                 :background)))
-      (when background
-        (return background)))))
-
-(defun shr-insert-foreground-overlay (fg start end)
+(defun shr-colorize-region (start end fg &optional bg)
   (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))))))))
+    (let ((new-colors (shr-color-check fg bg)))
+      (when new-colors
+	(shr-put-color start end :foreground (cadr new-colors))
+	(when bg
+	  (shr-put-color start end :background (car 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)))))))
+;; Put a color in the region, but avoid putting colors on on blank
+;; text at the start of the line, and the newline at the end, to avoid
+;; ugliness.  Also, don't overwrite any existing color information,
+;; since this can be called recursively, and we want the "inner" color
+;; to win.
+(defun shr-put-color (start end type color)
+  (save-excursion
+    (goto-char start)
+    (while (< (point) end)
+      (when (bolp)
+	(skip-chars-forward " "))
+      (when (> (line-end-position) (point))
+	(shr-put-color-1 (point) (min (line-end-position) end) type color))
+      (if (< (line-end-position) end)
+	  (forward-line 1)
+	(goto-char end)))))
+
+(defun shr-put-color-1 (start end type color)
+  (let* ((old-props (get-text-property start 'face))
+	 (do-put (not (memq type old-props)))
+	 change)
+    (while (< start end)
+      (setq change (next-single-property-change start 'face nil end))
+      (when do-put
+	(put-text-property start change 'face
+			   (nconc (list type color) old-props)))
+      (setq old-props (get-text-property change 'face))
+      (setq do-put (not (memq type old-props)))
+      (setq start change))
+    (when (and do-put
+	       (> end start))
+      (put-text-property start end 'face
+			 (nconc (list type color old-props))))))
 
 ;;; 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)
+  (let* ((start (point))
+	 (fgcolor (cdr (assq :fgcolor cont)))
+	 (bgcolor (cdr (assq :bgcolor cont)))
+	 (shr-stylesheet (list (cons :color fgcolor)
+			       (cons :background-color bgcolor))))
     (shr-generic cont)
-    (shr-insert-foreground-overlay fgcolor start (point))))
+    (shr-colorize-region start (point) fgcolor bgcolor)))
 
 (defun shr-tag-p (cont)
   (shr-ensure-paragraph)
@@ -669,10 +690,11 @@
 
 (defun shr-tag-a (cont)
   (let ((url (cdr (assq :href cont)))
+        (title (cdr (assq :title cont)))
 	(start (point))
 	shr-start)
     (shr-generic cont)
-    (shr-urlify (or shr-start start) url)))
+    (shr-urlify (or shr-start start) url title)))
 
 (defun shr-tag-object (cont)
   (let ((start (point))
@@ -818,7 +840,7 @@
   (let ((start (point))
         (color (cdr (assq :color cont))))
     (shr-generic cont)
-    (shr-insert-foreground-overlay color start (point))))
+    (shr-colorize-region start (point) color)))
 
 ;;; Table rendering algorithm.
 
@@ -870,7 +892,6 @@
 	 (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))))
@@ -1013,48 +1034,44 @@
     (nreverse trs)))
 
 (defun shr-render-td (cont width fill)
-  (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)))))))
+  (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))))))
 
 (defun shr-natural-width ()
   (goto-char (point-min))