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

111829:a60f0af8cb39

(defvar shr-inhibit-images nil)
(defvar shr-list-mode nil)
(defvar shr-content-cache nil)
(defvar shr-kinsoku-shorten nil)
(defvar shr-table-depth 0)

(defvar shr-map
  (let ((map (make-sparse-keymap)))
    (define-key map "a" 'shr-show-alt-text)
    (define-key map "i" 'shr-browse-image)

    (nreverse result)))

(defun shr-descend (dom)
  (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))
	(style (cdr (assq :style (cdr dom))))
	(start (point)))
    (when (and style
	       (string-match "color" style))
      (setq style (shr-parse-style style)))
    (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)))))

(defun shr-generic (cont)
  (dolist (sub cont)
    (cond
     ((eq (car sub) 'text)

  (apply #'shr-fontize-cont cont types)
  (shr-ensure-paragraph))

(autoload 'widget-convert-button "wid-edit")

(defun shr-urlify (start url)
  (widget-convert-button
   'url-link start (point)
   :help-echo url
   :keymap shr-map
   url)
  (put-text-property start (point) 'shr-url url))

(defun shr-encode-url (url)

               ;; 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 pos (1+ pos)))
    (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)
  (shr-generic cont)

		    plist)))))
      plist)))

(defun shr-tag-a (cont)
  (let ((url (cdr (assq :href cont)))
	(start (point))
	shr-start)
    (shr-generic cont)
    (shr-urlify (or shr-start start) url)))

(defun shr-tag-object (cont)
  (let ((start (point))
	url)
    (dolist (elem cont)

(defun shr-tag-font (cont)
  (let ((start (point))
        (color (cdr (assq :color cont))))
    (shr-generic cont)
    (shr-insert-foreground-overlay color start (point))))

;;; Table rendering algorithm.

;; Table rendering is the only complicated thing here.  We do this by
;; first counting how many TDs there are in each TR, and registering

	 (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))))
      (if header
	  (if footer

	      (setq i (1+ i))))
	  (push (nreverse tds) trs))))
    (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)))))))

(defun shr-natural-width ()
  (goto-char (point-min))
  (let ((current 0)
	(max 0))

111830:79219ca01c7b

(defvar shr-inhibit-images nil)
(defvar shr-list-mode nil)
(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)))
    (define-key map "a" 'shr-show-alt-text)
    (define-key map "i" 'shr-browse-image)

    (nreverse result)))

(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 shr-stylesheet (nconc (shr-parse-style style)
				  shr-stylesheet)))
    (if (fboundp function)
	(funcall function (cdr dom))
      (shr-generic (cdr dom)))
    (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)
    (cond
     ((eq (car sub) 'text)

  (apply #'shr-fontize-cont cont types)
  (shr-ensure-paragraph))

(autoload 'widget-convert-button "wid-edit")

(defun shr-urlify (start url &optional title)
  (widget-convert-button
   'url-link start (point)
   :help-echo (if title (format "%s (%s)" url title) url)
   :keymap shr-map
   url)
  (put-text-property start (point) 'shr-url url))

(defun shr-encode-url (url)

               ;; 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-colorize-region (start end fg &optional bg)
  (when fg
    (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)))))))

;; 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-stylesheet (list (cons :color fgcolor)
			       (cons :background-color bgcolor))))
    (shr-generic cont)
    (shr-colorize-region start (point) fgcolor bgcolor)))

(defun shr-tag-p (cont)
  (shr-ensure-paragraph)
  (shr-indent)
  (shr-generic cont)

		    plist)))))
      plist)))

(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 title)))

(defun shr-tag-object (cont)
  (let ((start (point))
	url)
    (dolist (elem cont)

(defun shr-tag-font (cont)
  (let ((start (point))
        (color (cdr (assq :color cont))))
    (shr-generic cont)
    (shr-colorize-region start (point) color)))

;;; Table rendering algorithm.

;; Table rendering is the only complicated thing here.  We do this by
;; first counting how many TDs there are in each TR, and registering

	 (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-tag-table-1
     (nconc
      (if caption `((tr (td ,@caption))))
      (if header
	  (if footer

	      (setq i (1+ i))))
	  (push (nreverse tds) trs))))
    (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))))))

(defun shr-natural-width ()
  (goto-char (point-min))
  (let ((current 0)
	(max 0))