;;; 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
(let ((map (make-sparse-keymap)))
(define-key map "a" 'shr-show-alt-text)
(define-key map "i" 'shr-browse-image)
+ (define-key map "z" 'shr-zoom-image)
(define-key map "I" 'shr-insert-image)
(define-key map "u" 'shr-copy-url)
(define-key map "v" 'shr-browse-url)
;; Public functions and commands.
-(defun shr-visit-file (file)
- (interactive "fHTML file name: ")
+(defun shr-render-buffer (buffer)
+ "Display the HTML rendering of the current buffer."
+ (interactive (list (current-buffer)))
(pop-to-buffer "*html*")
(erase-buffer)
(shr-insert-document
- (with-temp-buffer
- (insert-file-contents file)
- (libxml-parse-html-region (point-min) (point-max)))))
+ (with-current-buffer buffer
+ (libxml-parse-html-region (point-min) (point-max))))
+ (goto-char (point-min)))
+
+(defun shr-visit-file (file)
+ "Parse FILE as an HTML document, and render it in a new buffer."
+ (interactive "fHTML file name: ")
+ (with-temp-buffer
+ (insert-file-contents file)
+ (shr-render-buffer (current-buffer))))
;;;###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 (> (shr-previous-newline-padding-width (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 "Inserting %s..." url)
(url-retrieve url 'shr-image-fetched
(list (current-buffer) (1- (point)) (point-marker))
+ t t))))
+
+(defun shr-zoom-image ()
+ "Toggle the image size.
+The size will be rotated between the default size, the original
+size, and full-buffer size."
+ (interactive)
+ (let ((url (get-text-property (point) 'image-url))
+ (size (get-text-property (point) 'image-size))
+ (buffer-read-only nil))
+ (if (not url)
+ (message "No image under point")
+ ;; Delete the old picture.
+ (while (get-text-property (point) 'image-url)
+ (forward-char -1))
+ (forward-char 1)
+ (let ((start (point)))
+ (while (get-text-property (point) 'image-url)
+ (forward-char 1))
+ (forward-char -1)
+ (put-text-property start (point) 'display nil)
+ (when (> (- (point) start) 2)
+ (delete-region start (1- (point)))))
+ (message "Inserting %s..." url)
+ (url-retrieve url 'shr-image-fetched
+ (list (current-buffer) (1- (point)) (point-marker)
+ (list (cons 'size
+ (cond ((or (eq size 'default)
+ (null size))
+ 'original)
+ ((eq size 'original)
+ 'full)
+ ((eq size 'full)
+ 'default)))))
t))))
;;; Utility functions.
(defun shr-insert (text)
(when (and (eq shr-state 'image)
+ (not (bolp))
(not (string-match "\\`[ \t\n]+\\'" text)))
(insert "\n")
(setq shr-state nil))
((eq shr-folding-mode 'none)
(insert text))
(t
- (when (and (string-match "\\`[ \t\n]" text)
+ (when (and (string-match "\\`[ \t\n ]" text)
(not (bolp))
(not (eq (char-after (1- (point))) ? )))
(insert " "))
- (dolist (elem (split-string text))
+ (dolist (elem (split-string text "[ \f\t\n\r\v ]+" t))
(when (and (bolp)
(> shr-indentation 0))
(shr-indent))
(unless shr-start
(setq shr-start (point)))
(insert elem)
+ (setq shr-state nil)
(let (found)
(while (and (> (current-column) shr-width)
(progn
(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.
(when (eq (following-char) ? )
(delete-char 1)))
(shr-indent))
(end-of-line))
(insert " ")))
- (unless (string-match "[ \t\n]\\'" text)
+ (unless (string-match "[ \t\n ]\\'" text)
(delete-char -1)))))
(defun shr-find-fill-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)
+ ;; Find backward the point where kinsoku-eol characters begin.
+ (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))))
+ ((shr-char-kinsoku-bol-p (following-char))
+ ;; Find forward the point where kinsoku-bol characters end.
+ (let ((count 4))
+ (while (progn
+ (forward-char 1)
+ (and (>= (setq count (1- count)) 0)
(shr-char-kinsoku-bol-p (following-char))
- (shr-char-breakable-p (following-char)))
- (forward-char 1))))))
+ (shr-char-breakable-p (following-char))))))))
(when (eq (following-char) ? )
(forward-char 1))))
(not failed)))
(string-match "\\`[a-z]*:" url)
(not shr-base))
url)
+ ((and (string-match "\\`//" url)
+ (string-match "\\`[a-z]*:" shr-base))
+ (concat (match-string 0 shr-base) url))
((and (not (string-match "/\\'" shr-base))
(not (string-match "\\`/" url)))
(concat shr-base "/" url))
(if (save-excursion
(beginning-of-line)
(looking-at " *$"))
- (insert "\n")
+ (delete-region (match-beginning 0) (match-end 0))
(insert "\n\n")))))
(defun shr-indent ()
((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)
(expand-file-name (file-name-nondirectory url)
directory)))))
-(defun shr-image-fetched (status buffer start end)
- (when (and (buffer-name buffer)
- (not (plist-get status :error)))
- (url-store-in-cache (current-buffer))
- (when (or (search-forward "\n\n" nil t)
- (search-forward "\r\n\r\n" nil t))
- (let ((data (buffer-substring (point) (point-max))))
- (with-current-buffer buffer
- (save-excursion
- (let ((alt (buffer-substring start end))
- (inhibit-read-only t))
- (delete-region start end)
- (goto-char start)
- (funcall shr-put-image-function data alt)))))))
- (kill-buffer (current-buffer)))
-
-(defun shr-put-image (data alt)
+(defun shr-image-fetched (status buffer start end &optional flags)
+ (let ((image-buffer (current-buffer)))
+ (when (and (buffer-name buffer)
+ (not (plist-get status :error)))
+ (url-store-in-cache image-buffer)
+ (when (or (search-forward "\n\n" nil t)
+ (search-forward "\r\n\r\n" nil t))
+ (let ((data (buffer-substring (point) (point-max))))
+ (with-current-buffer buffer
+ (save-excursion
+ (let ((alt (buffer-substring start end))
+ (properties (text-properties-at start))
+ (inhibit-read-only t))
+ (delete-region start end)
+ (goto-char start)
+ (funcall shr-put-image-function data alt flags)
+ (while properties
+ (let ((type (pop properties))
+ (value (pop properties)))
+ (unless (memq type '(display image-size))
+ (put-text-property start (point) type value))))))))))
+ (kill-buffer image-buffer)))
+
+(defun shr-put-image (data alt &optional flags)
"Put image DATA with a string ALT. Return image."
(if (display-graphic-p)
- (let ((image (ignore-errors
- (shr-rescale-image data))))
+ (let* ((size (cdr (assq 'size flags)))
+ (start (point))
+ (image (cond
+ ((eq size 'original)
+ (create-image data nil t :ascent 100))
+ ((eq size 'full)
+ (ignore-errors
+ (shr-rescale-image data t)))
+ (t
+ (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 "*"))
+ (if (eq size 'original)
+ (let ((overlays (overlays-at (point))))
+ (insert-sliced-image image (or alt "*") nil 20 1)
+ (dolist (overlay overlays)
+ (overlay-put overlay 'face 'default)))
+ (insert-image image (or alt "*")))
+ (put-text-property start (point) 'image-size size)
(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
- :ascent 100)
- (let* ((image (create-image data nil t :ascent 100))
- (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
- :ascent 100)
- image)))
- image)))
+(defun shr-rescale-image (data &optional force)
+ "Rescale DATA, if too big, to fit the current buffer.
+If FORCE, rescale the image anyway."
+ (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 (or force
+ (> 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.
(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)
(forward-line 1)
(setq end (point))
(narrow-to-region start end)
- (let ((width (shr-natural-width))
+ (let ((width (shr-buffer-width))
column)
(goto-char (point-min))
(while (not (eobp))
(let ((file (url-cache-create-filename (shr-encode-url url))))
(when (file-exists-p file)
(delete-file file))))
- (funcall
- (if (fboundp 'url-queue-retrieve)
- 'url-queue-retrieve
- 'url-retrieve)
+ (url-queue-retrieve
(shr-encode-url url) 'shr-image-fetched
(list (current-buffer) start (set-marker (make-marker) (1- (point))))
- t)))
+ 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)
(shr-generic cont)))
(defun shr-tag-br (cont)
- (unless (bobp)
+ (when (and (not (bobp))
+ ;; Only add a newline if we break the current line, or
+ ;; the previous line isn't a blank line.
+ (or (not (bolp))
+ (and (> (- (point) 2) (point-min))
+ (not (= (char-after (- (point) 2)) ?\n)))))
(insert "\n")
(shr-indent))
(shr-generic cont))
;; be smaller (if there's little text) or bigger (if there's
;; unbreakable text).
(sketch (shr-make-table cont suggested-widths))
- (sketch-widths (shr-table-widths sketch suggested-widths)))
+ ;; Compute the "natural" width by setting each column to 500
+ ;; characters and see how wide they really render.
+ (natural (shr-make-table cont (make-vector (length columns) 500)))
+ (sketch-widths (shr-table-widths sketch natural suggested-widths)))
;; This probably won't work very well.
(when (> (+ (loop for width across sketch-widths
summing (1+ width))
shr-table-corner))
(insert "\n"))
-(defun shr-table-widths (table suggested-widths)
+(defun shr-table-widths (table natural-table suggested-widths)
(let* ((length (length suggested-widths))
(widths (make-vector length 0))
(natural-widths (make-vector length 0)))
(dolist (row table)
(let ((i 0))
(dolist (column row)
- (aset widths i (max (aref widths i)
- (car column)))
- (aset natural-widths i (max (aref natural-widths i)
- (cadr column)))
+ (aset widths i (max (aref widths i) column))
+ (setq i (1+ i)))))
+ (dolist (row natural-table)
+ (let ((i 0))
+ (dolist (column row)
+ (aset natural-widths i (max (aref natural-widths i) column))
(setq i (1+ i)))))
(let ((extra (- (apply '+ (append suggested-widths nil))
(apply '+ (append widths nil))))
(expanded-columns 0))
+ ;; We have extra, unused space, so divide this space amongst the
+ ;; columns.
(when (> extra 0)
+ ;; If the natural width is wider than the rendered width, we
+ ;; want to allow the column to expand.
(dotimes (i length)
- ;; If the natural width is wider than the rendered width, we
- ;; want to allow the column to expand.
(when (> (aref natural-widths i) (aref widths i))
(setq expanded-columns (1+ expanded-columns))))
(dotimes (i length)
(when (> (aref natural-widths i) (aref widths i))
(aset widths i (min
- (1+ (aref natural-widths i))
+ (aref natural-widths i)
(+ (/ extra expanded-columns)
(aref widths i))))))))
widths))
(let ((shr-width width)
(shr-indentation 0))
(shr-descend (cons 'td cont)))
+ ;; Delete padding at the bottom of the TDs.
(delete-region
(point)
- (+ (point)
- (skip-chars-backward " \t\n")))
+ (progn
+ (skip-chars-backward " \t\n")
+ (end-of-line)
+ (point)))
(push (list (cons width cont) (buffer-string)
(shr-overlays-in-region (point-min) (point-max)))
shr-content-cache)))
(split-string (buffer-string) "\n")
(shr-collect-overlays)
(car actual-colors))
- (list max
- (shr-natural-width)))))))
+ max)))))
-(defun shr-natural-width ()
+(defun shr-buffer-width ()
(goto-char (point-min))
- (let ((current 0)
- (max 0))
+ (let ((max 0))
(while (not (eobp))
(end-of-line)
- (setq current (+ current (current-column)))
- (unless (get-text-property (point) 'shr-break)
- (setq max (max max current)
- current 0))
+ (setq max (max max (current-column)))
(forward-line 1))
max))
(when (memq (car column) '(td th))
(let ((width (cdr (assq :width (cdr column)))))
(when (and width
- (string-match "\\([0-9]+\\)%" width))
- (aset columns i
- (/ (string-to-number (match-string 1 width))
- 100.0))))
+ (string-match "\\([0-9]+\\)%" width)
+ (not (zerop (setq width (string-to-number
+ (match-string 1 width))))))
+ (aset columns i (/ width 100.0))))
(setq i (1+ i)))))))
columns))
(provide 'shr)
+;; Local Variables:
+;; coding: iso-8859-1
+;; End:
+
;;; shr.el ends here