+(defun shr-image-displayer (content-function)
+ "Return a function to display an image.
+CONTENT-FUNCTION is a function to retrieve an image for a cid url that
+is an argument. The function to be returned takes three arguments URL,
+START, and END."
+ `(lambda (url start end)
+ (when url
+ (if (string-match "\\`cid:" url)
+ ,(when content-function
+ `(let ((image (funcall ,content-function
+ (substring url (match-end 0)))))
+ (when image
+ (goto-char start)
+ (shr-put-image image
+ (prog1
+ (buffer-substring-no-properties start end)
+ (delete-region start end))))))
+ (url-retrieve url 'shr-image-fetched
+ (list (current-buffer) start end)
+ t)))))
+
+(defun shr-heading (cont &rest types)
+ (shr-ensure-paragraph)
+ (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)
+ "Encode URL."
+ (browse-url-url-encode-chars url "[)$ ]"))
+
+(autoload 'shr-color-visible "shr-color")
+(autoload 'shr-color->hexadecimal "shr-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-colorize-region (start end fg &optional bg)
+ "Colorize region from START to END.
+Use foreground color FG and background color BG.
+Apply color check via `shr-color-check'."
+ (when (or fg bg)
+ (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 (if fgcolor
+ (if bgcolor
+ `((color . ,fgcolor)
+ (background-color . ,bgcolor) ,@shr-stylesheet)
+ `((color . ,fgcolor) ,@shr-stylesheet))
+ (if bgcolor
+ `((background-color . ,bgcolor) ,@shr-stylesheet)
+ shr-stylesheet))))
+ (shr-generic cont)))
+
+(defun shr-tag-p (cont)
+ (shr-ensure-paragraph)
+ (shr-indent)
+ (shr-generic cont)
+ (shr-ensure-paragraph))
+
+(defun shr-tag-div (cont)
+ (shr-ensure-newline)
+ (shr-indent)
+ (shr-generic cont)
+ (shr-ensure-newline))
+
+(defun shr-tag-b (cont)
+ (shr-fontize-cont cont 'bold))
+
+(defun shr-tag-i (cont)
+ (shr-fontize-cont cont 'italic))
+
+(defun shr-tag-em (cont)
+ (shr-fontize-cont cont 'bold))
+
+(defun shr-tag-strong (cont)
+ (shr-fontize-cont cont 'bold))
+
+(defun shr-tag-u (cont)
+ (shr-fontize-cont cont 'underline))
+
+(defun shr-tag-s (cont)
+ (shr-fontize-cont cont 'strike-through))
+
+(defun shr-parse-style (style)
+ (when style
+ (save-match-data
+ (when (string-match "\n" style)
+ (setq style (replace-match " " t t style))))
+ (let ((plist nil))
+ (dolist (elem (split-string style ";"))
+ (when elem
+ (setq elem (split-string elem ":"))
+ (when (and (car elem)
+ (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)))))
+ 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)
+ (when (eq (car elem) 'embed)
+ (setq url (or url (cdr (assq :src (cdr elem))))))
+ (when (and (eq (car elem) 'param)
+ (equal (cdr (assq :name (cdr elem))) "movie"))
+ (setq url (or url (cdr (assq :value (cdr elem)))))))
+ (when url
+ (shr-insert " [multimedia] ")
+ (shr-urlify start url))
+ (shr-generic cont)))
+
+(defun shr-tag-video (cont)
+ (let ((image (cdr (assq :poster cont)))
+ (url (cdr (assq :src cont)))
+ (start (point)))
+ (shr-tag-img nil image)
+ (shr-urlify start url)))
+
+(defun shr-tag-img (cont &optional url)
+ (when (or url
+ (and cont
+ (cdr (assq :src cont))))
+ (when (and (> (current-column) 0)
+ (not (eq shr-state 'image)))
+ (insert "\n"))
+ (let ((alt (cdr (assq :alt cont)))
+ (url (or url (cdr (assq :src cont)))))
+ (let ((start (point-marker)))
+ (when (zerop (length alt))
+ (setq alt "*"))
+ (cond
+ ((or (member (cdr (assq :height cont)) '("0" "1"))
+ (member (cdr (assq :width cont)) '("0" "1")))
+ ;; Ignore zero-sized or single-pixel images.
+ )
+ ((and (not shr-inhibit-images)
+ (string-match "\\`cid:" url))
+ (let ((url (substring url (match-end 0)))
+ image)
+ (if (or (not shr-content-function)
+ (not (setq image (funcall shr-content-function url))))
+ (insert alt)
+ (shr-put-image image alt))))
+ ((or shr-inhibit-images
+ (and shr-blocked-images
+ (string-match shr-blocked-images url)))
+ (setq shr-start (point))
+ (let ((shr-state 'space))
+ (if (> (string-width alt) 8)
+ (shr-insert (truncate-string-to-width alt 8))
+ (shr-insert alt))))
+ ((url-is-cached (shr-encode-url url))
+ (shr-put-image (shr-get-image-data url) alt))
+ (t
+ (insert alt)
+ (ignore-errors
+ (url-retrieve (shr-encode-url url) 'shr-image-fetched
+ (list (current-buffer) start (point-marker))
+ t))))
+ (put-text-property start (point) 'keymap shr-map)
+ (put-text-property start (point) 'shr-alt alt)
+ (put-text-property start (point) 'image-url url)
+ (put-text-property start (point) 'image-displayer
+ (shr-image-displayer shr-content-function))
+ (put-text-property start (point) 'help-echo alt)
+ (setq shr-state 'image)))))
+
+(defun shr-tag-pre (cont)
+ (let ((shr-folding-mode 'none))
+ (shr-ensure-newline)
+ (shr-indent)
+ (shr-generic cont)
+ (shr-ensure-newline)))
+
+(defun shr-tag-blockquote (cont)
+ (shr-ensure-paragraph)
+ (shr-indent)
+ (let ((shr-indentation (+ shr-indentation 4)))
+ (shr-generic cont))
+ (shr-ensure-paragraph))