shr: colorize only in one place

[gnus] / lisp / shr.el

diff --git a/lisp/shr.el b/lisp/shr.el
index 73649a2..8ee1e99 100644 (file)
--- a/lisp/shr.el
+++ b/lisp/shr.el
@@ -32,8 +32,6 @@
 
 (eval-when-compile (require 'cl))
 (require 'browse-url)
 
 (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"
 
 (defgroup shr nil
   "Simple HTML Renderer"


@@ -96,6 +94,7 @@ cid: URL as the argument.")
 (defvar shr-content-cache nil)
 (defvar shr-kinsoku-shorten nil)
 (defvar shr-table-depth 0)
 (defvar shr-content-cache nil)
 (defvar shr-kinsoku-shorten nil)
 (defvar shr-table-depth 0)

+(defvar shr-stylesheet nil)

 
 (defvar shr-map
   (let ((map (make-sparse-keymap)))
 
 (defvar shr-map
   (let ((map (make-sparse-keymap)))


@@ -193,18 +192,22 @@ redirects somewhere else."
 (defun shr-descend (dom)
   (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))
        (style (cdr (assq :style (cdr dom))))
 (defun shr-descend (dom)
   (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))
        (style (cdr (assq :style (cdr dom))))

+       (shr-stylesheet shr-stylesheet)

        (start (point)))
     (when (and style
        (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))
               (string-match "color" style))

-      (setq style (shr-parse-style style)))
+      (setq shr-stylesheet (nconc (shr-parse-style style)
+                                 shr-stylesheet)))
+    ;; Render content

     (if (fboundp function)
        (funcall function (cdr dom))
       (shr-generic (cdr dom)))
     (if (fboundp function)
        (funcall function (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)))))
+    ;; 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)
 
 (defun shr-generic (cont)
   (dolist (sub cont)


@@ -214,6 +217,26 @@ redirects somewhere else."
      ((listp (cdr sub))
       (shr-descend sub)))))
 
      ((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)))
 (defun shr-insert (text)
   (when (and (eq shr-state 'image)
             (not (string-match "\\`[ \t\n]+\\'" text)))


@@ -242,12 +265,11 @@ redirects somewhere else."
       (let (prev)
        (when (and (eq (preceding-char) ? )
                   (or (= (line-beginning-position) (1- (point)))
       (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)
          (delete-char -1)))
       (insert elem)
       (let (found)


@@ -273,44 +295,88 @@ redirects somewhere else."
 (defun shr-find-fill-point ()
   (when (> (move-to-column shr-width) shr-width)
     (backward-char 1))
 (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))
+                   (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))
       (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.
     (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 ? )))
                        (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))
 
 (defun shr-ensure-newline ()
   (unless (zerop (current-column))


@@ -483,10 +549,10 @@ START, and END."
 
 (autoload 'widget-convert-button "wid-edit")
 
 
 (autoload 'widget-convert-button "wid-edit")
 

-(defun shr-urlify (start url)
+(defun shr-urlify (start url &optional title)

   (widget-convert-button
    'url-link start (point)
   (widget-convert-button
    'url-link start (point)

-   :help-echo url
+   :help-echo (if title (format "%s (%s)" url title) url)

    :keymap shr-map
    url)
   (put-text-property start (point) 'shr-url url))
    :keymap shr-map
    url)
   (put-text-property start (point) 'shr-url url))


@@ -520,38 +586,66 @@ ones, in case fg and bg are nil."
               (t
                (shr-color-visible bg fg)))))))
 
               (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))))))
-      (message (format "BG FOUND: %s" bg))
-      (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)))
+(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
       (when new-colors

-        (overlay-put (make-overlay start start nil nil t) 'face
-                     (list :background (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)
 
 ;;; 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))))
+  (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)
 
 (defun shr-tag-p (cont)
   (shr-ensure-paragraph)


@@ -596,6 +690,8 @@ text will be inserted at start."
                     (cadr elem))
            (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem)))
                  (value (replace-regexp-in-string "^ +\\| +$" "" (cadr 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)))))
              (push (cons (intern name obarray)
                          value)
                    plist)))))


@@ -603,10 +699,11 @@ text will be inserted at start."
 
 (defun shr-tag-a (cont)
   (let ((url (cdr (assq :href cont)))
 
 (defun shr-tag-a (cont)
   (let ((url (cdr (assq :href cont)))

+        (title (cdr (assq :title cont)))

        (start (point))
        shr-start)
     (shr-generic cont)
        (start (point))
        shr-start)
     (shr-generic cont)

-    (shr-urlify (or shr-start start) url)))
+    (shr-urlify (or shr-start start) url title)))

 
 (defun shr-tag-object (cont)
   (let ((start (point))
 
 (defun shr-tag-object (cont)
   (let ((start (point))


@@ -749,10 +846,12 @@ text will be inserted at start."
   (shr-heading cont 'bold 'underline))
 
 (defun shr-tag-font (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))))
+  (let* ((start (point))
+         (color (cdr (assq :color cont)))
+         (shr-stylesheet (if color
+                             `((color . ,fgcolor) ,@shr-stylesheet)
+                           shr-stylesheet)))
+    (shr-generic cont)))

 
 ;;; Table rendering algorithm.
 
 
 ;;; Table rendering algorithm.
 


@@ -800,6 +899,7 @@ text will be inserted at start."
         (header (cdr (assq 'thead cont)))
         (body (or (cdr (assq 'tbody cont)) cont))
         (footer (cdr (assq 'tfoot cont)))
         (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))))
         (nheader (if header (shr-max-columns header)))
         (nbody (if body (shr-max-columns body)))
         (nfooter (if footer (shr-max-columns footer))))


@@ -951,7 +1051,7 @@ text will be inserted at start."
          (insert cache)
        (let ((shr-width width)
              (shr-indentation 0))
          (insert cache)
        (let ((shr-width width)
              (shr-indentation 0))

-         (shr-generic cont))
+         (shr-descend (cons 'td cont)))

        (delete-region
         (point)
         (+ (point)
        (delete-region
         (point)
         (+ (point)