;;; shr.el --- Simple HTML Renderer
-;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2012 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: html
(defgroup shr nil
"Simple HTML Renderer"
+ :version "24.1"
:group 'mail)
(defcustom shr-max-image-proportion 0.9
:group 'shr
:type 'regexp)
-(defcustom shr-table-horizontal-line ?
+(defcustom shr-table-horizontal-line ?\s
"Character used to draw horizontal table lines."
:group 'shr
:type 'character)
-(defcustom shr-table-vertical-line ?
+(defcustom shr-table-vertical-line ?\s
"Character used to draw vertical table lines."
:group 'shr
:type 'character)
-(defcustom shr-table-corner ?
+(defcustom shr-table-corner ?\s
"Character used to draw table corners."
:group 'shr
:type 'character)
(defvar shr-table-depth 0)
(defvar shr-stylesheet nil)
(defvar shr-base nil)
+(defvar shr-ignore-cache nil)
(defvar shr-map
(let ((map (make-sparse-keymap)))
;; Public functions and commands.
(defun shr-visit-file (file)
+ "Parse FILE as an HTML document, and render it in a new buffer."
(interactive "fHTML file name: ")
(pop-to-buffer "*html*")
(erase-buffer)
(shr-insert-document
(with-temp-buffer
(insert-file-contents file)
- (libxml-parse-html-region (point-min) (point-max)))))
+ (libxml-parse-html-region (point-min) (point-max))))
+ (goto-char (point-min)))
;;;###autoload
(defun shr-insert-document (dom)
+ "Render the parsed document DOM into the current buffer.
+DOM should be a parse tree as generated by
+`libxml-parse-html-region' or similar."
(setq shr-content-cache nil)
- (let ((shr-state nil)
+ (let ((start (point))
+ (shr-state nil)
(shr-start nil)
(shr-base nil)
(shr-width (or shr-width (window-width))))
- (shr-descend (shr-transform-dom dom))))
+ (shr-descend (shr-transform-dom dom))
+ (shr-remove-trailing-whitespace start (point))))
+
+(defun shr-remove-trailing-whitespace (start end)
+ (let ((width (window-width)))
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char start)
+ (while (not (eobp))
+ (end-of-line)
+ (when (> (current-column) width)
+ (dolist (overlay (overlays-at (point)))
+ (when (overlay-get overlay 'before-string)
+ (overlay-put overlay 'before-string nil))))
+ (forward-line 1)))))
(defun shr-copy-url ()
"Copy the URL under point to the kill ring.
(when (re-search-forward ".utm_.*" nil t)
(replace-match "" t t))
(message "Copied %s" (buffer-string))
- (copy-region-as-kill (point-min) (point-max)))))))
+ (copy-region-as-kill (point-min) (point-max)))))
+ nil t))
;; Copy the URL to the kill ring.
(t
(with-temp-buffer
(message "No image under point")
(message "%s" text))))
-(defun shr-browse-image ()
- "Browse the image under point."
- (interactive)
+(defun shr-browse-image (&optional copy-url)
+ "Browse the image under point.
+If COPY-URL (the prefix if called interactively) is non-nil, copy
+the URL of the image to the kill buffer instead."
+ (interactive "P")
(let ((url (get-text-property (point) 'image-url)))
- (if (not url)
- (message "No image under point")
+ (cond
+ ((not url)
+ (message "No image under point"))
+ (copy-url
+ (with-temp-buffer
+ (insert url)
+ (copy-region-as-kill (point-min) (point-max))
+ (message "Copied %s" url)))
+ (t
(message "Browsing %s..." url)
- (browse-url url))))
+ (browse-url url)))))
(defun shr-insert-image ()
"Insert the image under point into the buffer."
(message "Inserting %s..." url)
(url-retrieve url 'shr-image-fetched
(list (current-buffer) (1- (point)) (point-marker))
- t))))
+ t t))))
;;; Utility functions.
((not url)
(message "No link under point"))
((string-match "^mailto:" url)
- (browse-url-mailto url))
+ (browse-url-mail url))
(t
(browse-url url)))))
(if (not url)
(message "No link under point")
(url-retrieve (shr-encode-url url)
- 'shr-store-contents (list url directory)))))
+ 'shr-store-contents (list url directory)
+ nil t))))
(defun shr-store-contents (status url directory)
(unless (plist-get status :error)
(when (and (> (current-column) 0)
(> (car (image-size image t)) 400))
(insert "\n"))
- (insert-image image (or alt "*")))
+ (insert-image image (or alt "*"))
+ (when (image-animated-p image)
+ (image-animate image nil 60)))
image)
(insert alt)))
(defun shr-rescale-image (data)
- (if (or (not (fboundp 'imagemagick-types))
- (not (get-buffer-window (current-buffer))))
- (create-image data nil t)
- (let* ((image (create-image data nil t))
- (size (image-size image t))
- (width (car size))
- (height (cdr size))
- (edges (window-inside-pixel-edges
- (get-buffer-window (current-buffer))))
- (window-width (truncate (* shr-max-image-proportion
- (- (nth 2 edges) (nth 0 edges)))))
- (window-height (truncate (* shr-max-image-proportion
- (- (nth 3 edges) (nth 1 edges)))))
- scaled-image)
- (when (> height window-height)
- (setq image (or (create-image data 'imagemagick t
- :height window-height)
- image))
- (setq size (image-size image t)))
- (when (> (car size) window-width)
- (setq image (or
- (create-image data 'imagemagick t
- :width window-width)
- image)))
- (when (and (fboundp 'create-animated-image)
- (eq (image-type data nil t) 'gif))
- (setq image (create-animated-image data 'gif t)))
- image)))
+ (let ((image (create-image data nil t :ascent 100)))
+ (if (or (not (fboundp 'imagemagick-types))
+ (not (get-buffer-window (current-buffer))))
+ image
+ (let* ((size (image-size image t))
+ (width (car size))
+ (height (cdr size))
+ (edges (window-inside-pixel-edges
+ (get-buffer-window (current-buffer))))
+ (window-width (truncate (* shr-max-image-proportion
+ (- (nth 2 edges) (nth 0 edges)))))
+ (window-height (truncate (* shr-max-image-proportion
+ (- (nth 3 edges) (nth 1 edges)))))
+ scaled-image)
+ (when (> height window-height)
+ (setq image (or (create-image data 'imagemagick t
+ :height window-height
+ :ascent 100)
+ image))
+ (setq size (image-size image t)))
+ (when (> (car size) window-width)
+ (setq image (or
+ (create-image data 'imagemagick t
+ :width window-width
+ :ascent 100)
+ 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")
+(autoload 'browse-url-mail "browse-url")
(defun shr-get-image-data (url)
"Get image data for URL.
"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."
+START, and END. Note that START and END should be markers."
`(lambda (url start end)
(when url
(if (string-match "\\`cid:" url)
(when image
(goto-char start)
(funcall shr-put-image-function
- image (buffer-substring-no-properties start end))
+ image (buffer-substring start end))
(delete-region (point) end))))
(url-retrieve url 'shr-image-fetched
(list (current-buffer) start end)
- t)))))
+ t t)))))
(defun shr-heading (cont &rest types)
(shr-ensure-paragraph)
:help-echo (if title (format "%s (%s)" url title) url)
:keymap shr-map
url)
- (put-text-property start (point) 'face 'shr-link)
+ (shr-add-font start (point) 'shr-link)
(put-text-property start (point) 'shr-url url))
(defun shr-encode-url (url)
(shr-put-color start end :background (car new-colors))))
new-colors)))
-;; Put a color in the region, but avoid putting colors on on blank
+;; Put a color in the region, but avoid putting colors 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
(defun shr-tag-script (cont)
)
+(defun shr-tag-comment (cont)
+ )
+
(defun shr-tag-sup (cont)
(let ((start (point)))
(shr-generic cont)
(defun shr-tag-s (cont)
(shr-fontize-cont cont 'shr-strike-through))
+(defun shr-tag-del (cont)
+ (shr-fontize-cont cont 'shr-strike-through))
+
(defun shr-tag-b (cont)
(shr-fontize-cont cont 'bold))
(if (> (string-width alt) 8)
(shr-insert (truncate-string-to-width alt 8))
(shr-insert alt))))
- ((url-is-cached (shr-encode-url url))
+ ((and (not shr-ignore-cache)
+ (url-is-cached (shr-encode-url url)))
(funcall shr-put-image-function (shr-get-image-data url) alt))
(t
- (insert alt)
- (funcall
- (if (fboundp 'url-queue-retrieve)
- 'url-queue-retrieve
- 'url-retrieve)
+ (insert alt " ")
+ (when (and shr-ignore-cache
+ (url-is-cached (shr-encode-url url)))
+ (let ((file (url-cache-create-filename (shr-encode-url url))))
+ (when (file-exists-p file)
+ (delete-file file))))
+ (url-queue-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)
+ (list (current-buffer) start (set-marker (make-marker) (1- (point))))
+ t t)))
+ (when (zerop shr-table-depth) ;; We are not in a table.
+ (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)
(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 (and (not caption)
+ (not header)
+ (not (cdr (assq 'tbody cont)))
+ (not (cdr (assq 'tr cont)))
+ (not footer))
+ ;; The table is totally invalid and just contains random junk.
+ ;; Try to output it anyway.
+ (shr-generic cont)
+ ;; It's a real table, so render it.
+ (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)
- (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)))))
+ `((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))))