shr.el (shr-find-fill-point): Work better for kinsoku chars and apostrophes.

[gnus] / lisp / shr.el

diff --git a/lisp/shr.el b/lisp/shr.el
index b195f6b..0b85cfb 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"


@@ -201,7 +199,10 @@ redirects somewhere else."
        (funcall function (cdr dom))
       (shr-generic (cdr dom)))
     (when (consp style)
        (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)
 
 (defun shr-generic (cont)
   (dolist (sub cont)


@@ -211,6 +212,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 +260,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 +290,87 @@ 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))
+                   (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))
       (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))


@@ -494,22 +557,65 @@ 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."
-  (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.
 
 
 ;;; 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)
 (defun shr-tag-p (cont)
   (shr-ensure-paragraph)
   (shr-indent)


@@ -553,6 +659,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)))))


@@ -702,11 +810,14 @@ 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)
   (let ((start (point))
         (color (cdr (assq :color cont))))
     (shr-generic cont)
 (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.
 
 
 ;;; Table rendering algorithm.
 


@@ -754,9 +865,11 @@ 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))))

+    (shr-insert-background-overlay bgcolor (point))

     (shr-tag-table-1
      (nconc
       (if caption `((tr (td ,@caption))))
     (shr-tag-table-1
      (nconc
       (if caption `((tr (td ,@caption))))


@@ -899,44 +1012,48 @@ START, and END."
     (nreverse trs)))
 
 (defun shr-render-td (cont width fill)
     (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))
 
 (defun shr-natural-width ()
   (goto-char (point-min))