diff options
Diffstat (limited to 'lisp/gnus/shr.el')
| -rw-r--r-- | lisp/gnus/shr.el | 738 |
1 files changed, 569 insertions, 169 deletions
diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el index 6499b35d072..692d1262348 100644 --- a/lisp/gnus/shr.el +++ b/lisp/gnus/shr.el @@ -53,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) @@ -87,6 +92,9 @@ cid: URL as the argument.") (defvar shr-inhibit-images nil) (defvar shr-list-mode nil) (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))) @@ -95,6 +103,7 @@ cid: URL as the argument.") (define-key map "I" 'shr-insert-image) (define-key map "u" 'shr-copy-url) (define-key map "v" 'shr-browse-url) + (define-key map "o" 'shr-save-contents) (define-key map "\r" 'shr-browse-url) map)) @@ -149,7 +158,7 @@ redirects somewhere else." (defun shr-browse-image () "Browse the image under point." (interactive) - (let ((url (get-text-property (point) 'shr-image))) + (let ((url (get-text-property (point) 'image-url))) (if (not url) (message "No image under point") (message "Browsing %s..." url) @@ -158,7 +167,7 @@ redirects somewhere else." (defun shr-insert-image () "Insert the image under point into the buffer." (interactive) - (let ((url (get-text-property (point) 'shr-image))) + (let ((url (get-text-property (point) 'image-url))) (if (not url) (message "No image under point") (message "Inserting %s..." url) @@ -176,24 +185,57 @@ redirects somewhere else." result)) (dolist (sub dom) (if (stringp sub) - (push (cons :text sub) result) + (push (cons 'text sub) result) (push (shr-transform-dom sub) result))) (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 style + (if (string-match "color" style) + (setq shr-stylesheet (nconc (shr-parse-style style) + shr-stylesheet)) + (setq style nil))) (if (fboundp function) (funcall function (cdr dom)) - (shr-generic (cdr dom))))) + (shr-generic (cdr dom))) + ;; If style is set, then this node has set the color. + (when style + (shr-colorize-region start (point) + (cdr (assq 'color shr-stylesheet)) + (cdr (assq 'background-color shr-stylesheet)))))) (defun shr-generic (cont) (dolist (sub cont) (cond - ((eq (car sub) :text) + ((eq (car sub) 'text) (shr-insert (cdr 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))) @@ -203,78 +245,137 @@ redirects somewhere else." ((eq shr-folding-mode 'none) (insert text)) (t - (let ((first t) - column) - (when (and (string-match "\\`[ \t\n]" text) - (not (bolp)) - (not (eq (char-after (1- (point))) ? ))) - (insert " ")) - (dolist (elem (split-string text)) - (when (and (bolp) - (> shr-indentation 0)) - (shr-indent)) - ;; The shr-start is a special variable that is used to pass - ;; upwards the first point in the buffer where the text really - ;; starts. - (unless shr-start - (setq shr-start (point))) - ;; No space is needed before or after a breakable character or - ;; at the beginning of a line. + (when (and (string-match "\\`[ \t\n]" text) + (not (bolp)) + (not (eq (char-after (1- (point))) ? ))) + (insert " ")) + (dolist (elem (split-string text)) + (when (and (bolp) + (> shr-indentation 0)) + (shr-indent)) + ;; The shr-start is a special variable that is used to pass + ;; upwards the first point in the buffer where the text really + ;; starts. + (unless shr-start + (setq shr-start (point))) + ;; No space is needed behind a wide character categorized as + ;; kinsoku-bol, between characters both categorized as nospace, + ;; or at the beginning of a line. + (let (prev) (when (and (eq (preceding-char) ? ) (or (= (line-beginning-position) (1- (point))) - (aref fill-find-break-point-function-table - (char-after (- (point) 2))) - (aref fill-find-break-point-function-table - (aref elem 0)))) - (delete-char -1)) - (insert elem) - (while (> (current-column) shr-width) - (unless (prog1 - (shr-find-fill-point) - (when (eq (preceding-char) ? ) - (delete-char -1)) - (insert "\n")) + (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) + (while (and (> (current-column) shr-width) + (progn + (setq found (shr-find-fill-point)) + (not (eolp)))) + (when (eq (preceding-char) ? ) + (delete-char -1)) + (insert "\n") + (unless found (put-text-property (1- (point)) (point) 'shr-break t) ;; No space is needed at the beginning of a line. - (if (eq (following-char) ? ) - (delete-char 1))) + (when (eq (following-char) ? ) + (delete-char 1))) (when (> shr-indentation 0) (shr-indent)) (end-of-line)) - (insert " ")) - (unless (string-match "[ \t\n]\\'" text) - (delete-char -1)))))) - -(eval-and-compile (autoload 'kinsoku-longer "kinsoku")) + (insert " "))) + (unless (string-match "[ \t\n]\\'" text) + (delete-char -1))))) (defun shr-find-fill-point () - (let ((found nil)) - (while (and (not found) - (> (current-column) shr-indentation)) - (when (and (or (eq (preceding-char) ? ) - (aref fill-find-break-point-function-table - (preceding-char))) - (<= (current-column) shr-width)) - (setq found t)) - (backward-char 1) - (when (bolp) + (when (> (move-to-column shr-width) shr-width) + (backward-char 1)) + (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 ? ))) + (and (shr-char-kinsoku-bol-p (preceding-char)) + (shr-char-breakable-p (following-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. - (end-of-line) - (while (aref fill-find-break-point-function-table - (preceding-char)) - (backward-char 1)) - (setq found 'failed))) - (cond ((eq found t) - ;; Don't put kinsoku-bol characters at the beginning of a line. - (or (eobp) - (kinsoku-longer) - (not (aref fill-find-break-point-function-table - (following-char))) - (forward-char 1))) - (found t) - (t - (end-of-line) - nil)))) + (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 (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)) @@ -303,17 +404,49 @@ redirects somewhere else." (dolist (type types) (shr-add-font (or shr-start (point)) (point) type)))) +;; Add an overlay in the region, but avoid putting the font properties +;; on blank text at the start of the line, and the newline at the end, +;; to avoid ugliness. (defun shr-add-font (start end type) - (let ((overlay (make-overlay start end))) - (overlay-put overlay 'face type))) + (save-excursion + (goto-char start) + (while (< (point) end) + (when (bolp) + (skip-chars-forward " ")) + (let ((overlay (make-overlay (point) (min (line-end-position) end)))) + (overlay-put overlay 'face type)) + (if (< (line-end-position) end) + (forward-line 1) + (goto-char end))))) (defun shr-browse-url () "Browse the URL under point." (interactive) (let ((url (get-text-property (point) 'shr-url))) + (cond + ((not url) + (message "No link under point")) + ((string-match "^mailto:" url) + (browse-url-mailto url)) + (t + (browse-url url))))) + +(defun shr-save-contents (directory) + "Save the contents from URL in a file." + (interactive "DSave contents of URL to directory: ") + (let ((url (get-text-property (point) 'shr-url))) (if (not url) (message "No link under point") - (browse-url url)))) + (url-retrieve (shr-encode-url url) + 'shr-store-contents (list url directory))))) + +(defun shr-store-contents (status url directory) + (unless (plist-get status :error) + (when (or (search-forward "\n\n" nil t) + (search-forward "\r\n\r\n" nil t)) + (write-region (point) (point-max) + (expand-file-name (file-name-nondirectory url) + directory))))) (defun shr-image-fetched (status buffer start end) (when (and (buffer-name buffer) @@ -326,16 +459,22 @@ redirects somewhere else." (let ((alt (buffer-substring start end)) (inhibit-read-only t)) (delete-region start end) - (shr-put-image data start alt)))))) + (goto-char start) + (shr-put-image data alt)))))) (kill-buffer (current-buffer))) -(defun shr-put-image (data point alt) - (if (not (display-graphic-p)) - (insert alt) - (let ((image (ignore-errors - (shr-rescale-image data)))) - (when image - (put-image image point alt))))) +(defun shr-put-image (data alt) + (if (display-graphic-p) + (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))) (defun shr-rescale-image (data) (if (or (not (fboundp 'imagemagick-types)) @@ -364,6 +503,11 @@ redirects somewhere else." image))) image))) +;; url-cache-extract autoloads url-cache. +(declare-function url-cache-create-filename "url-cache" (url)) +(autoload 'mm-disable-multibyte "mm-util") +(autoload 'browse-url-mailto "browse-url") + (defun shr-get-image-data (url) "Get image data for URL. Return a string with image data." @@ -376,19 +520,146 @@ 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. Note that START and END should be merkers." + `(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 + (buffer-substring-no-properties start end)) + (delete-region (point) 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) (shr-ensure-paragraph)) +(autoload 'widget-convert-button "wid-edit") + +(defun shr-urlify (start url &optional title) + (widget-convert-button + 'url-link start (point) + :help-echo (if title (format "%s (%s)" url title) url) + :keymap shr-map + url) + (put-text-property start (point) 'shr-url url)) + +(defun shr-encode-url (url) + "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) + (when (or fg bg) + (let ((new-colors (shr-color-check fg bg))) + (when new-colors + (when fg + (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 (list (cons 'color fgcolor) + (cons 'background-color bgcolor)))) + (shr-generic cont) + (shr-colorize-region start (point) fgcolor bgcolor))) + +(defun shr-tag-style (cont) + ) + +(defun shr-tag-script (cont) + ) + +(defun shr-tag-label (cont) + (shr-generic cont) + (shr-ensure-paragraph)) + (defun shr-tag-p (cont) (shr-ensure-paragraph) (shr-indent) (shr-generic cont) (shr-ensure-paragraph)) +(defun shr-tag-div (cont) + (shr-ensure-newline) + (shr-indent) + (shr-generic cont) + (shr-ensure-newline)) + (defun shr-tag-b (cont) (shr-fontize-cont cont 'bold)) @@ -398,59 +669,81 @@ Return a string with image data." (defun shr-tag-em (cont) (shr-fontize-cont cont 'bold)) +(defun shr-tag-strong (cont) + (shr-fontize-cont cont 'bold)) + (defun shr-tag-u (cont) (shr-fontize-cont cont 'underline)) (defun shr-tag-s (cont) (shr-fontize-cont cont 'strike-through)) +(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 + (setq elem (split-string elem ":")) + (when (and (car 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))))) + plist))) + (defun shr-tag-a (cont) (let ((url (cdr (assq :href cont))) + (title (cdr (assq :title cont))) (start (point)) shr-start) (shr-generic cont) - (widget-convert-button - 'url-link (or shr-start start) (point) - :help-echo url - :keymap shr-map - url) - (put-text-property (or shr-start start) (point) 'shr-url url))) + (shr-urlify (or shr-start start) url title))) -(defun shr-encode-url (url) - "Encode URL." - (browse-url-url-encode-chars url "[)$ ]")) +(defun shr-tag-object (cont) + (let ((start (point)) + url) + (dolist (elem cont) + (when (eq (car elem) 'embed) + (setq url (or url (cdr (assq :src (cdr elem)))))) + (when (and (eq (car elem) 'param) + (equal (cdr (assq :name (cdr elem))) "movie")) + (setq url (or url (cdr (assq :value (cdr elem))))))) + (when url + (shr-insert " [multimedia] ") + (shr-urlify start url)) + (shr-generic cont))) -(defun shr-tag-img (cont) - (when cont +(defun shr-tag-video (cont) + (let ((image (cdr (assq :poster cont))) + (url (cdr (assq :src cont))) + (start (point))) + (shr-tag-img nil image) + (shr-urlify start url))) + +(defun shr-tag-img (cont &optional url) + (when (or url + (and cont + (cdr (assq :src cont)))) (when (and (> (current-column) 0) (not (eq shr-state 'image))) (insert "\n")) (let ((alt (cdr (assq :alt cont))) - (url (cdr (assq :src cont))) - (width (cdr (assq :width cont)))) - ;; Only respect align if width specified. - (when width - ;; Check that width is not larger than max width, otherwise ignore - ;; align - (let ((max-width (* shr-width (frame-char-width))) - (width (string-to-number width))) - (when (< width max-width) - (let ((align (cdr (assq :align cont)))) - (cond - ((string= align "right") - (insert (propertize - " " 'display - `(space . (:align-to - ,(list (- max-width width))))))) - ((string= align "center") - (insert (propertize - " " 'display - `(space . (:balign-to - ,(list (- (/ max-width 2) width)))))))))))) + (url (or url (cdr (assq :src cont))))) (let ((start (point-marker))) (when (zerop (length alt)) - (setq alt "[img]")) + (setq alt "*")) (cond + ((or (member (cdr (assq :height cont)) '("0" "1")) + (member (cdr (assq :width cont)) '("0" "1"))) + ;; Ignore zero-sized or single-pixel images. + ) ((and (not shr-inhibit-images) (string-match "\\`cid:" url)) (let ((url (substring url (match-end 0))) @@ -458,27 +751,29 @@ Return a string with image data." (if (or (not shr-content-function) (not (setq image (funcall shr-content-function url)))) (insert alt) - (shr-put-image image (point) alt)))) + (shr-put-image image alt)))) ((or shr-inhibit-images (and shr-blocked-images (string-match shr-blocked-images url))) (setq shr-start (point)) (let ((shr-state 'space)) - (if (> (length alt) 8) - (shr-insert (substring alt 0 8)) + (if (> (string-width alt) 8) + (shr-insert (truncate-string-to-width alt 8)) (shr-insert alt)))) ((url-is-cached (shr-encode-url url)) - (shr-put-image (shr-get-image-data url) (point) alt)) + (shr-put-image (shr-get-image-data url) alt)) (t (insert alt) (ignore-errors (url-retrieve (shr-encode-url url) 'shr-image-fetched (list (current-buffer) start (point-marker)) t)))) - (insert " ") (put-text-property start (point) 'keymap shr-map) (put-text-property start (point) 'shr-alt alt) - (put-text-property start (point) 'shr-image url) + (put-text-property start (point) 'image-url url) + (put-text-property start (point) 'image-displayer + (shr-image-displayer shr-content-function)) + (put-text-property start (point) 'help-echo alt) (setq shr-state 'image))))) (defun shr-tag-pre (cont) @@ -548,6 +843,19 @@ 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 (nconc (list (cons 'color color)) + shr-stylesheet))) + (shr-generic cont) + (when color + (shr-colorize-region start (point) color + (cdr (assq 'background-color shr-stylesheet)))))) + ;;; Table rendering algorithm. ;; Table rendering is the only complicated thing here. We do this by @@ -558,11 +866,12 @@ Return a string with image data." ;; main buffer). Now we know how much space each TD really takes, so ;; we then render everything again with the new widths, and finally ;; insert all these boxes into the main buffer. -(defun shr-tag-table (cont) - (shr-ensure-paragraph) +(defun shr-tag-table-1 (cont) (setq cont (or (cdr (assq 'tbody cont)) cont)) (let* ((shr-inhibit-images t) + (shr-table-depth (1+ shr-table-depth)) + (shr-kinsoku-shorten t) ;; Find all suggested widths. (columns (shr-column-specs cont)) ;; Compute how many characters wide each TD should be. @@ -573,8 +882,9 @@ Return a string with image data." (sketch (shr-make-table cont suggested-widths)) (sketch-widths (shr-table-widths sketch suggested-widths))) ;; This probably won't work very well. - (when (> (1+ (loop for width across sketch-widths - summing (1+ width))) + (when (> (+ (loop for width across sketch-widths + summing (1+ width)) + shr-indentation 1) (frame-width)) (setq truncate-lines t)) ;; Then render the table again with these new "hard" widths. @@ -582,8 +892,64 @@ Return a string with image data." ;; Finally, insert all the images after the table. The Emacs buffer ;; model isn't strong enough to allow us to put the images actually ;; into the tables. - (dolist (elem (shr-find-elements cont 'img)) - (shr-tag-img (cdr elem)))) + (when (zerop shr-table-depth) + (dolist (elem (shr-find-elements cont 'img)) + (shr-tag-img (cdr elem))))) + +(defun shr-tag-table (cont) + (shr-ensure-paragraph) + (let* ((caption (cdr (assq 'caption cont))) + (header (cdr (assq 'thead cont))) + (body (or (cdr (assq 'tbody cont)) cont)) + (footer (cdr (assq 'tfoot cont))) + (bgcolor (cdr (assq :bgcolor cont))) + (start (point)) + (shr-stylesheet (nconc (list (cons 'background-color bgcolor)) + shr-stylesheet)) + (nheader (if header (shr-max-columns header))) + (nbody (if body (shr-max-columns body))) + (nfooter (if footer (shr-max-columns footer)))) + (shr-tag-table-1 + (nconc + (if caption `((tr (td ,@caption)))) + (if header + (if footer + ;; hader + body + footer + (if (= nheader nbody) + (if (= nbody nfooter) + `((tr (td (table (tbody ,@header ,@body ,@footer))))) + (nconc `((tr (td (table (tbody ,@header ,@body))))) + (if (= nfooter 1) + footer + `((tr (td (table (tbody ,@footer)))))))) + (nconc `((tr (td (table (tbody ,@header))))) + (if (= nbody nfooter) + `((tr (td (table (tbody ,@body ,@footer))))) + (nconc `((tr (td (table (tbody ,@body))))) + (if (= nfooter 1) + footer + `((tr (td (table (tbody ,@footer)))))))))) + ;; header + body + (if (= nheader nbody) + `((tr (td (table (tbody ,@header ,@body))))) + (if (= nheader 1) + `(,@header (tr (td (table (tbody ,@body))))) + `((tr (td (table (tbody ,@header)))) + (tr (td (table (tbody ,@body)))))))) + (if footer + ;; body + footer + (if (= nbody nfooter) + `((tr (td (table (tbody ,@body ,@footer))))) + (nconc `((tr (td (table (tbody ,@body))))) + (if (= nfooter 1) + footer + `((tr (td (table (tbody ,@footer)))))))) + (if caption + `((tr (td (table (tbody ,@body))))) + body))))) + (when bgcolor + (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet)) + bgcolor)))) (defun shr-find-elements (cont type) (let (result) @@ -604,7 +970,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)) @@ -613,7 +979,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))) @@ -625,15 +991,19 @@ Return a string with image data." ;; possibly. (dotimes (i (- height (length lines))) (end-of-line) - (insert (make-string (length (car lines)) ? ) "|") + (insert (make-string (string-width (car lines)) ? ) + shr-table-vertical-line) (forward-line 1))))) (shr-insert-table-ruler widths))) (defun shr-insert-table-ruler (widths) - (shr-indent) + (when (and (bolp) + (> shr-indentation 0)) + (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) @@ -685,43 +1055,73 @@ Return a string with image data." (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 + (let ((bgcolor (cdr (assq :bgcolor cont))) + (fgcolor (cdr (assq :fgcolor cont))) + (style (cdr (assq :style cont))) + (shr-stylesheet shr-stylesheet) + overlays) + (when style + (setq style (and (string-match "color" style) + (shr-parse-style style)))) + (when bgcolor + (setq style (nconc (list (cons 'background-color bgcolor)) style))) + (when fgcolor + (setq style (nconc (list (cons 'color fgcolor)) style))) + (when style + (setq shr-stylesheet (append style shr-stylesheet))) + (let ((cache (cdr (assoc (cons width cont) shr-content-cache)))) + (if cache + (progn + (insert (car cache)) + (let ((end (length (car cache)))) + (dolist (overlay (cadr cache)) + (let ((new-overlay + (make-overlay (1+ (- end (nth 0 overlay))) + (1+ (- end (nth 1 overlay))))) + (properties (nth 2 overlay))) + (while properties + (overlay-put new-overlay + (pop properties) (pop properties))))))) + (let ((shr-width width) + (shr-indentation 0)) + (shr-descend (cons 'td cont))) + (delete-region + (point) + (+ (point) + (skip-chars-backward " \t\n"))) + (push (list (cons width cont) (buffer-string) + (shr-overlays-in-region (point-min) (point-max))) + 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)))) + (when style + (shr-colorize-region + (point-min) (point-max) + (cdr (assq 'color shr-stylesheet)) + (cdr (assq 'background-color shr-stylesheet)))) + (if fill + (list max + (count-lines (point-min) (point-max)) + (split-string (buffer-string) "\n") + (shr-collect-overlays)) (list max - (count-lines (point-min) (point-max)) - (split-string (buffer-string) "\n") - (shr-collect-overlays)) - (list max - (shr-natural-width)))))) + (shr-natural-width))))))) (defun shr-natural-width () (goto-char (point-min)) |