(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"
: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 'char)
+ :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 'char)
+ :type 'character)
(defcustom shr-hr-line ?-
- "Character used to draw hr line."
+ "Character used to draw hr lines."
:group 'shr
- :type 'char)
+ :type 'character)
(defcustom shr-width fill-column
"Frame width to use for rendering."
(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-map
(let ((map (make-sparse-keymap)))
(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))
(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)
(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)
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))))
+ (start (point)))
+ (when (and style
+ (string-match "color" style))
+ (setq style (shr-parse-style style)))
(if (fboundp function)
(funcall function (cdr dom))
- (shr-generic (cdr dom)))))
+ (shr-generic (cdr dom)))
+ (when (consp style)
+ (shr-insert-color-overlay (cdr (assq 'color style)) start (point)))))
(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)))))
((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)))
- (insert elem)
- (while (> (current-column) shr-width)
- (if (not (shr-find-fill-point))
- (insert "\n")
- (delete-char 1)
- (insert "\n")
+ (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)))
+ (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)))))
+ (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)
- (when (> shr-indentation 0)
- (shr-indent))
- (end-of-line)))
- (insert " "))
- (unless (string-match "[ \t\n]\\'" text)
- (delete-char -1))))))
+ ;; No space is needed at the beginning of a line.
+ (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)))))
(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 (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))))
(backward-char 1))
- (or found
- (end-of-line))))
+ (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)
+ (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)))))
(defun shr-ensure-newline ()
(unless (zerop (current-column))
(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)
(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))
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."
(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)
(shr-ensure-paragraph))
+(autoload 'widget-convert-button "wid-edit")
+
+(defun shr-urlify (start url)
+ (widget-convert-button
+ 'url-link start (point)
+ :help-echo 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 &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
+ (let ((overlay (make-overlay start end)))
+ (overlay-put overlay 'face (cons 'foreground-color
+ (cadr (shr-color-check color)))))))
+
;;; Tag-specific rendering rules.
(defun shr-tag-p (cont)
(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))
(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))))
+ (push (cons (intern name obarray)
+ value)
+ plist)))))
+ plist)))
+
(defun shr-tag-a (cont)
(let ((url (cdr (assq :href cont)))
(start (point))
shr-start)
(shr-generic cont)
- (widget-convert-button
- 'link (or shr-start start) (point)
- :help-echo url)
- (put-text-property (or shr-start start) (point) 'keymap shr-map)
- (put-text-property (or shr-start start) (point) 'shr-url url)))
+ (shr-urlify (or shr-start start) url)))
-(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 (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))))))))))))
- (let ((start (point-marker)))
- (when (zerop (length alt))
- (setq alt "[img]"))
- (cond
- ((and (not shr-inhibit-images)
- (string-match "\\`cid:" url))
- (let ((url (substring url (match-end 0)))
- image)
- (if (or (not shr-content-function)
- (not (setq image (funcall shr-content-function url))))
- (insert alt)
- (shr-put-image image (point) 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))
- (shr-insert alt))))
- ((url-is-cached (shr-encode-url url))
- (shr-put-image (shr-get-image-data url) (point) 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)
- (setq shr-state 'image))))
+(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 (or url (cdr (assq :src cont)))))
+ (let ((start (point-marker)))
+ (when (zerop (length alt))
+ (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)))
+ image)
+ (if (or (not shr-content-function)
+ (not (setq image (funcall shr-content-function url))))
+ (insert 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 (> (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) alt))
+ (t
+ (insert alt)
+ (ignore-errors
+ (url-retrieve (shr-encode-url url) 'shr-image-fetched
+ (list (current-buffer) start (point-marker))
+ t))))
+ (put-text-property start (point) 'keymap shr-map)
+ (put-text-property start (point) 'shr-alt alt)
+ (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)
(let ((shr-folding-mode 'none))
(shr-ensure-newline)
(insert (make-string shr-width shr-hr-line) "\n"))
+(defun shr-tag-font (cont)
+ (let ((start (point))
+ (color (cdr (assq :color cont))))
+ (shr-generic cont)
+ (shr-insert-color-overlay color start (point))))
+
;;; Table rendering algorithm.
;; Table rendering is the only complicated thing here. We do this by
;; 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.
;; unbreakable text).
(sketch (shr-make-table cont suggested-widths))
(sketch-widths (shr-table-widths sketch suggested-widths)))
+ ;; This probably won't work very well.
+ (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.
(shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths))
;; 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)))
+ (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)))))))
(defun shr-find-elements (cont type)
(let (result)
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))
(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)))
;; 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)