X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fshr.el;h=8ee1e99397fc2f57a7c8c309705830e1ffbfbb3d;hb=9a2e7412ae672c1b2c7169513646e8acfd7f53fe;hp=1aec8caa350e5f5962ebae6bbfef91cb34aaa06b;hpb=60b8d7f080f334bc6585d3c6f565bb8c9a6ded08;p=gnus diff --git a/lisp/shr.el b/lisp/shr.el index 1aec8caa3..8ee1e9939 100644 --- a/lisp/shr.el +++ b/lisp/shr.el @@ -195,18 +195,19 @@ redirects somewhere else." (shr-stylesheet shr-stylesheet) (start (point))) (when (and style + ;; HACK: we only parse if there's color information, since + ;; that's the only thing we are rendering. (string-match "color" style)) (setq shr-stylesheet (nconc (shr-parse-style style) shr-stylesheet))) + ;; Render content (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))))) + ;; Apply style + (shr-colorize-region start (point) + (cdr (assq 'color shr-stylesheet)) + (cdr (assq 'background-color shr-stylesheet))))) (defun shr-generic (cont) (dolist (sub cont) @@ -301,12 +302,12 @@ redirects somewhere else." (eq (following-char) ? ) (shr-char-breakable-p (preceding-char)) (shr-char-breakable-p (following-char)) - (and (eq (preceding-char) ?') - (not (memq (char-after (- (point) 2)) - (list nil ?\n ? )))) - ;; There're some kinsoku CJK chars that aren't breakable. - (and (shr-char-kinsoku-bol-p (preceding-char)) - (not (shr-char-kinsoku-bol-p (following-char)))) + (if (eq (preceding-char) ?') + (not (memq (char-after (- (point) 2)) + (list nil ?\n ? ))) + ;; There're some kinsoku CJK chars that aren't breakable. + (and (shr-char-kinsoku-bol-p (preceding-char)) + (not (shr-char-kinsoku-bol-p (following-char))))) (shr-char-kinsoku-eol-p (following-char)))) (backward-char 1)) (if (and (not (or failed (eolp))) @@ -586,23 +587,65 @@ ones, in case fg and bg are nil." (shr-color-visible bg fg))))))) (defun shr-colorize-region (start end fg &optional bg) - (when fg - (let ((new-colors - (shr-color-check fg (or bg - (frame-parameter nil 'background-color))))) + "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 - (overlay-put (make-overlay start end) 'face - (list :foreground (cadr new-colors) - :background (and bg (car 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-generic cont) - (shr-colorize-region start (point) fgcolor bgcolor))) + (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) @@ -803,10 +846,12 @@ ones, in case fg and bg are nil." (shr-heading cont 'bold 'underline)) (defun shr-tag-font (cont) - (let ((start (point)) - (color (cdr (assq :color cont)))) - (shr-generic cont) - (shr-colorize-region start (point) color))) + (let* ((start (point)) + (color (cdr (assq :color cont))) + (shr-stylesheet (if color + `((color . ,fgcolor) ,@shr-stylesheet) + shr-stylesheet))) + (shr-generic cont))) ;;; Table rendering algorithm. @@ -1006,7 +1051,7 @@ ones, in case fg and bg are nil." (insert cache) (let ((shr-width width) (shr-indentation 0)) - (shr-generic cont)) + (shr-descend (cons 'td cont))) (delete-region (point) (+ (point)