shr: colorize only in one place

[gnus] / lisp / shr.el

diff --git a/lisp/shr.el b/lisp/shr.el
index 36c8d70..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,15 +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-color-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)


@@ -211,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)))


@@ -239,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)


@@ -270,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))


@@ -480,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))


@@ -494,23 +563,90 @@ START, and END."
 
 (autoload 'shr-color-visible "shr-color")
 (autoload 'shr-color->hexadecimal "shr-color")
 
 (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
-                    (cons 'foreground-color 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-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
+       (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.
 
 
 ;;; Tag-specific rendering rules.
 

+(defun shr-tag-body (cont)
+  (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)
   (shr-indent)
 (defun shr-tag-p (cont)
   (shr-ensure-paragraph)
   (shr-indent)


@@ -554,6 +690,8 @@ START, and END."
                     (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)))))


@@ -561,10 +699,11 @@ START, and END."
 
 (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))


@@ -703,11 +842,16 @@ START, and END."
   (shr-ensure-newline)
   (insert (make-string shr-width shr-hr-line) "\n"))
 
   (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)
 (defun shr-tag-font (cont)

-  (let ((start (point))
-        (color (cdr (assq :color cont))))
-    (shr-generic cont)
-    (shr-insert-color-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.
 


@@ -755,6 +899,7 @@ START, and END."
         (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))))


@@ -906,7 +1051,7 @@ START, and END."
          (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)