:group 'shr
:type 'regexp)
-(defcustom shr-table-line ?-
- "Character used to draw table line."
+(defcustom shr-table-horizontal-line ?-
+ "Character used to draw horizontal table lines."
+ :group 'shr
+ :type 'character)
+
+(defcustom shr-table-vertical-line ?|
+ "Character used to draw vertical table lines."
:group 'shr
:type 'character)
(defcustom shr-table-corner ?+
- "Character used to draw table corner."
+ "Character used to draw table corners."
:group 'shr
:type 'character)
(defcustom shr-hr-line ?-
- "Character used to draw hr line."
+ "Character used to draw hr lines."
:group 'shr
:type 'character)
(nreverse result)))
(defun shr-descend (dom)
- (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray)))
+ (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)))))
+ (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)
(let ((image (ignore-errors
(shr-rescale-image data))))
(when image
+ ;; When inserting big-ish pictures, put them at the
+ ;; beginning of the line.
+ (when (and (> (current-column) 0)
+ (> (car (image-size image t)) 400))
+ (insert "\n"))
(insert-image image (or alt "*"))))
(insert alt)))
is an argument. The function to be returned takes three arguments URL,
START, and END."
`(lambda (url start end)
- (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))))
+ (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)
"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-insert-foreground-overlay (fg start end)
+ (when fg
+ (let ((bg
+ (dolist (overlay (overlays-in start end))
+ (let ((background (plist-get (overlay-get overlay 'face)
+ :background)))
+ (when background
+ (return background))))))
+ (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 read-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)
(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
(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)))))
(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-foreground-overlay color start (point))))
+
;;; Table rendering algorithm.
;; Table rendering is the only complicated thing here. We do this by
max)))
(dotimes (i height)
(shr-indent)
- (insert "|\n"))
+ (insert shr-table-vertical-line "\n"))
(dolist (column row)
(goto-char start)
(let ((lines (nth 2 column))
(dolist (line lines)
(setq overlay-line (pop overlay-lines))
(end-of-line)
- (insert line "|")
+ (insert line shr-table-vertical-line)
(dolist (overlay overlay-line)
(let ((o (make-overlay (- (point) (nth 0 overlay) 1)
(- (point) (nth 1 overlay) 1)))
;; possibly.
(dotimes (i (- height (length lines)))
(end-of-line)
- (insert (make-string (string-width (car lines)) ? ) "|")
+ (insert (make-string (string-width (car lines)) ? )
+ shr-table-vertical-line)
(forward-line 1)))))
(shr-insert-table-ruler widths)))
(shr-indent))
(insert shr-table-corner)
(dotimes (i (length widths))
- (insert (make-string (aref widths i) shr-table-line) shr-table-corner))
+ (insert (make-string (aref widths i) shr-table-horizontal-line)
+ shr-table-corner))
(insert "\n"))
(defun shr-table-widths (table suggested-widths)
projects / gnus / blobdiff