(eval-when-compile (require 'cl))
(require 'browse-url)
-(unless (aref (char-category-set (make-char 'japanese-jisx0208 33 35)) ?>)
- (load "kinsoku" nil t))
(defgroup shr nil
"Simple HTML Renderer"
(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)
((listp (cdr sub))
(shr-descend sub)))))
+(defmacro shr-char-breakable-p (char)
+ "Return non-nil if a line can be broken before and after CHAR."
+ `(aref fill-find-break-point-function-table ,char))
+(defmacro shr-char-nospace-p (char)
+ "Return non-nil if no space is required before and after CHAR."
+ `(aref fill-nospace-between-words-table ,char))
+
+;; KINSOKU is a Japanese word meaning a rule that should not be violated.
+;; In Emacs, it is a term used for characters, e.g. punctuation marks,
+;; parentheses, and so on, that should not be placed in the beginning
+;; of a line or the end of a line.
+(defmacro shr-char-kinsoku-bol-p (char)
+ "Return non-nil if a line ought not to begin with CHAR."
+ `(aref (char-category-set ,char) ?>))
+(defmacro shr-char-kinsoku-eol-p (char)
+ "Return non-nil if a line ought not to end with CHAR."
+ `(aref (char-category-set ,char) ?<))
+(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
+ (load "kinsoku" nil t))
+
(defun shr-insert (text)
(when (and (eq shr-state 'image)
(not (string-match "\\`[ \t\n]+\\'" text)))
(let (prev)
(when (and (eq (preceding-char) ? )
(or (= (line-beginning-position) (1- (point)))
- (and (aref fill-find-break-point-function-table
- (setq prev (char-after (- (point) 2))))
- (aref (char-category-set prev) ?>))
- (and (aref fill-nospace-between-words-table prev)
- (aref fill-nospace-between-words-table
- (aref elem 0)))))
+ (and (shr-char-breakable-p
+ (setq prev (char-after (- (point) 2))))
+ (shr-char-kinsoku-bol-p prev))
+ (and (shr-char-nospace-p prev)
+ (shr-char-nospace-p (aref elem 0)))))
(delete-char -1)))
(insert elem)
(let (found)
(defun shr-find-fill-point ()
(when (> (move-to-column shr-width) shr-width)
(backward-char 1))
- (let (failed)
- (while (not
- (or (setq failed (= (current-column) shr-indentation))
- (eq (preceding-char) ? )
- (eq (following-char) ? )
- (aref fill-find-break-point-function-table (preceding-char))))
+ (let ((bp (point))
+ failed)
+ (while (not (or (setq failed (= (current-column) shr-indentation))
+ (eq (preceding-char) ? )
+ (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.
+ (shr-char-kinsoku-bol-p (preceding-char))
+ (shr-char-kinsoku-eol-p (following-char))))
(backward-char 1))
+ (if (and (not (or failed (eolp)))
+ (eq (preceding-char) ?'))
+ (while (not (or (setq failed (eolp))
+ (eq (following-char) ? )
+ (shr-char-breakable-p (following-char))
+ (shr-char-kinsoku-eol-p (following-char))))
+ (forward-char 1)))
(if failed
;; There's no breakable point, so we give it up.
- (progn
- (end-of-line)
- (while (aref fill-find-break-point-function-table (preceding-char))
- (backward-char 1))
- nil)
- (or (eolp)
- ;; Don't put kinsoku-bol characters at the beginning of a line,
- ;; or kinsoku-eol characters at the end of a line,
- (let ((count 4))
- (if (or shr-kinsoku-shorten
- (and (aref (char-category-set (preceding-char)) ?<)
- (progn
- (setq count (1- count))
- (backward-char 1)
- t)))
- (while (and
- (>= (setq count (1- count)) 0)
+ (let (found)
+ (goto-char bp)
+ (unless shr-kinsoku-shorten
+ (while (and (setq found (re-search-forward
+ "\\(\\c>\\)\\| \\|\\c<\\|\\c|"
+ (line-end-position) 'move))
+ (eq (preceding-char) ?')))
+ (if (and found (not (match-beginning 1)))
+ (goto-char (match-beginning 0)))))
+ (or
+ (eolp)
+ ;; Don't put kinsoku-bol characters at the beginning of a line,
+ ;; or kinsoku-eol characters at the end of a line.
+ (cond
+ (shr-kinsoku-shorten
+ (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
+ (shr-char-kinsoku-eol-p (preceding-char)))
+ (backward-char 1))
+ (when (setq failed (= (current-column) shr-indentation))
+ ;; There's no breakable point that doesn't violate kinsoku,
+ ;; so we look for the second best position.
+ (while (and (progn
+ (forward-char 1)
+ (<= (current-column) shr-width))
+ (progn
+ (setq bp (point))
+ (shr-char-kinsoku-eol-p (following-char)))))
+ (goto-char bp)))
+ ((shr-char-kinsoku-eol-p (preceding-char))
+ (if (shr-char-kinsoku-eol-p (following-char))
+ ;; There are consecutive kinsoku-eol characters.
+ (setq failed t)
+ (let ((count 4))
+ (while
+ (progn
+ (backward-char 1)
+ (and (> (setq count (1- count)) 0)
(not (memq (preceding-char) (list ?\C-@ ?\n ? )))
- (or (aref (char-category-set (preceding-char)) ?<)
- (aref (char-category-set (following-char)) ?>)))
- (backward-char 1))
- (while (and (>= (setq count (1- count)) 0)
- (aref (char-category-set (following-char)) ?>)
- (aref fill-find-break-point-function-table
- (following-char)))
- (forward-char 1)))
- (when (eq (following-char) ? )
- (forward-char 1))
- t)))))
+ (or (shr-char-kinsoku-eol-p (preceding-char))
+ (shr-char-kinsoku-bol-p (following-char)))))))
+ (if (setq failed (= (current-column) shr-indentation))
+ ;; There's no breakable point that doesn't violate kinsoku,
+ ;; so we go to the second best position.
+ (if (looking-at "\\(\\c<+\\)\\c<")
+ (goto-char (match-end 1))
+ (forward-char 1)))))
+ (t
+ (if (shr-char-kinsoku-bol-p (preceding-char))
+ ;; There are consecutive kinsoku-bol characters.
+ (setq failed t)
+ (let ((count 4))
+ (while (and (>= (setq count (1- count)) 0)
+ (shr-char-kinsoku-bol-p (following-char))
+ (shr-char-breakable-p (following-char)))
+ (forward-char 1))))))
+ (when (eq (following-char) ? )
+ (forward-char 1))))
+ (not failed)))
(defun shr-ensure-newline ()
(unless (zerop (current-column))
(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."
- (shr-color-visible (or (shr-color->hexadecimal bg)
- (frame-parameter nil 'background-color))
- (shr-color->hexadecimal fg) (not bg)))
-
-(defun shr-insert-color-overlay (color start end)
- (when color
- (when (string-match " " color)
- (setq color (car (split-string color))))
- (let ((overlay (make-overlay start end)))
- (overlay-put overlay 'face (cons 'foreground-color
- (cadr (shr-color-check 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 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)
(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-color-overlay color start (point))))
+ (shr-insert-foreground-overlay color start (point))))
;;; Table rendering algorithm.
(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))))
(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))
projects / gnus / blobdiff