X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fshr.el;h=26d2b3b4cd2a2cc114f1d4512290edb3ed7cb4b7;hb=c6a0508ba27bdef91d6323c86fa286db61d221d6;hp=57b9cea48ea4789e8720d3561c361e60a9346456;hpb=c71d65375a8f66d1a72963dd02020da1ef96276f;p=gnus diff --git a/lisp/shr.el b/lisp/shr.el index 57b9cea48..26d2b3b4c 100644 --- a/lisp/shr.el +++ b/lisp/shr.el @@ -201,7 +201,10 @@ redirects somewhere else." (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 @@ START, and END." (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 - (list :foreground 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 @@ START, and END." (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 @@ START, and END." (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 @@ START, and END." (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 @@ START, and END." (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))