X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fshr.el;h=8ee1e99397fc2f57a7c8c309705830e1ffbfbb3d;hb=9a2e7412ae672c1b2c7169513646e8acfd7f53fe;hp=4f3b20531f599e39997461b36f1e98c50cd04d43;hpb=6dd239d8257f04d0967933ac66be8d49bc1457fe;p=gnus diff --git a/lisp/shr.el b/lisp/shr.el index 4f3b20531..8ee1e9939 100644 --- a/lisp/shr.el +++ b/lisp/shr.el @@ -32,8 +32,6 @@ (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" @@ -55,18 +53,23 @@ fit these criteria." :group 'shr :type 'regexp) -(defcustom shr-table-line ?- - "Character used to draw table line." +(defcustom shr-table-horizontal-line ?- + "Character used to draw horizontal table lines." + :group 'shr + :type 'character) + +(defcustom shr-table-vertical-line ?| + "Character used to draw vertical table lines." :group 'shr :type 'character) (defcustom shr-table-corner ?+ - "Character used to draw table corner." + "Character used to draw table corners." :group 'shr :type 'character) (defcustom shr-hr-line ?- - "Character used to draw hr line." + "Character used to draw hr lines." :group 'shr :type 'character) @@ -91,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-stylesheet nil) (defvar shr-map (let ((map (make-sparse-keymap))) @@ -186,10 +190,24 @@ redirects somewhere else." (nreverse result))) (defun shr-descend (dom) - (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))) + (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 + ;; 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))))) + (shr-generic (cdr dom))) + ;; 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) @@ -199,6 +217,26 @@ redirects somewhere else." ((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))) @@ -227,12 +265,11 @@ redirects somewhere else." (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) @@ -258,44 +295,88 @@ redirects somewhere else." (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)) + (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)) @@ -388,6 +469,11 @@ redirects somewhere else." (let ((image (ignore-errors (shr-rescale-image data)))) (when image + ;; When inserting big-ish pictures, put them at the + ;; beginning of the line. + (when (and (> (current-column) 0) + (> (car (image-size image t)) 400)) + (insert "\n")) (insert-image image (or alt "*")))) (insert alt))) @@ -435,6 +521,27 @@ Return a string with image data." (search-forward "\r\n\r\n" nil t)) (buffer-substring (point) (point-max)))))) +(defun shr-image-displayer (content-function) + "Return a function to display an image. +CONTENT-FUNCTION is a function to retrieve an image for a cid url that +is an argument. The function to be returned takes three arguments URL, +START, and END." + `(lambda (url start end) + (when url + (if (string-match "\\`cid:" url) + ,(when content-function + `(let ((image (funcall ,content-function + (substring url (match-end 0))))) + (when image + (goto-char start) + (shr-put-image image + (prog1 + (buffer-substring-no-properties start end) + (delete-region start end)))))) + (url-retrieve url 'shr-image-fetched + (list (current-buffer) start end) + t))))) + (defun shr-heading (cont &rest types) (shr-ensure-paragraph) (apply #'shr-fontize-cont cont types) @@ -442,10 +549,10 @@ Return a string with image data." (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) - :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)) @@ -454,8 +561,92 @@ Return a string with image data." "Encode URL." (browse-url-url-encode-chars url "[)$ ]")) +(autoload 'shr-color-visible "shr-color") +(autoload 'shr-color->hexadecimal "shr-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. +(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) @@ -488,6 +679,9 @@ Return a string with image data." (defun shr-parse-style (style) (when style + (save-match-data + (when (string-match "\n" style) + (setq style (replace-match " " t t style)))) (let ((plist nil)) (dolist (elem (split-string style ";")) (when elem @@ -496,6 +690,8 @@ Return a string with image data." (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))))) @@ -503,10 +699,11 @@ Return a string with image data." (defun shr-tag-a (cont) (let ((url (cdr (assq :href cont))) + (title (cdr (assq :title 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)) @@ -574,10 +771,7 @@ Return a string with image data." (put-text-property start (point) 'shr-alt alt) (put-text-property start (point) 'image-url url) (put-text-property start (point) 'image-displayer - (lambda (url start end) - (url-retrieve url 'shr-image-fetched - (list (current-buffer) start end) - t))) + (shr-image-displayer shr-content-function)) (put-text-property start (point) 'help-echo alt) (setq shr-state 'image))))) @@ -648,6 +842,17 @@ Return a string with image data." (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-stylesheet (if color + `((color . ,fgcolor) ,@shr-stylesheet) + shr-stylesheet))) + (shr-generic cont))) + ;;; Table rendering algorithm. ;; Table rendering is the only complicated thing here. We do this by @@ -694,6 +899,7 @@ Return a string with image data." (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)))) @@ -755,7 +961,7 @@ Return a string with image data." max))) (dotimes (i height) (shr-indent) - (insert "|\n")) + (insert shr-table-vertical-line "\n")) (dolist (column row) (goto-char start) (let ((lines (nth 2 column)) @@ -764,7 +970,7 @@ Return a string with image data." (dolist (line lines) (setq overlay-line (pop overlay-lines)) (end-of-line) - (insert line "|") + (insert line shr-table-vertical-line) (dolist (overlay overlay-line) (let ((o (make-overlay (- (point) (nth 0 overlay) 1) (- (point) (nth 1 overlay) 1))) @@ -776,7 +982,8 @@ Return a string with image data." ;; possibly. (dotimes (i (- height (length lines))) (end-of-line) - (insert (make-string (string-width (car lines)) ? ) "|") + (insert (make-string (string-width (car lines)) ? ) + shr-table-vertical-line) (forward-line 1))))) (shr-insert-table-ruler widths))) @@ -786,7 +993,8 @@ Return a string with image data." (shr-indent)) (insert shr-table-corner) (dotimes (i (length widths)) - (insert (make-string (aref widths i) shr-table-line) shr-table-corner)) + (insert (make-string (aref widths i) shr-table-horizontal-line) + shr-table-corner)) (insert "\n")) (defun shr-table-widths (table suggested-widths) @@ -843,7 +1051,7 @@ Return a string with image data." (insert cache) (let ((shr-width width) (shr-indentation 0)) - (shr-generic cont)) + (shr-descend (cons 'td cont))) (delete-region (point) (+ (point)