;;; shr.el --- Simple HTML Renderer
-;; Copyright (C) 2010-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2014 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: html
"Character used to draw horizontal table lines.
If nil, don't draw horizontal table lines."
:group 'shr
- :type 'character)
+ :type '(choice (const nil) character))
(defcustom shr-table-vertical-line ?\s
"Character used to draw vertical table lines."
Alternative suggestions are:
- \" \"
- \" \""
+ :version "24.4"
:type 'string
:group 'shr)
:group 'shr
:type 'function)
+(defcustom shr-image-animate t
+ "Non nil means that images that can be animated will be."
+ :version "24.4"
+ :group 'shr
+ :type 'boolean)
+
(defvar shr-content-function nil
"If bound, this should be a function that will return the content.
This is used for cid: URLs, and the function is called with the
(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 [tab] 'shr-next-link)
- (define-key map [backtab] 'shr-previous-link)
+ (define-key map [?\t] 'shr-next-link)
+ (define-key map [?\M-\t] 'shr-previous-link)
(define-key map [follow-link] 'mouse-face)
(define-key map [mouse-2] 'shr-browse-url)
(define-key map "I" 'shr-insert-image)
(libxml-parse-html-region (point-min) (point-max))))
(goto-char (point-min)))
+;;;###autoload
(defun shr-render-region (begin end &optional buffer)
"Display the HTML rendering of the region between BEGIN and END."
(interactive "r")
(goto-char begin)
(shr-insert-document dom))))
-(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.
(shr-state nil)
(shr-start nil)
(shr-base nil)
- (shr-preliminary-table-render 0)
(shr-width (or shr-width (1- (window-width)))))
(shr-descend (shr-transform-dom dom))
(shr-remove-trailing-whitespace start (point))))
(push (shr-transform-dom sub) result)))
(nreverse result)))
+(defsubst shr-generic (cont)
+ (dolist (sub cont)
+ (cond
+ ((eq (car sub) 'text)
+ (shr-insert (cdr sub)))
+ ((listp (cdr sub))
+ (shr-descend sub)))))
+
(defun shr-descend (dom)
(let ((function
(or
(setq shr-stylesheet (nconc (shr-parse-style style)
shr-stylesheet))
(setq style nil)))
- ;; If we have a display:none, then just ignore this part of the
- ;; DOM.
+ ;; If we have a display:none, then just ignore this part of the DOM.
(unless (equal (cdr (assq 'display shr-stylesheet)) "none")
(if (fboundp function)
(funcall function (cdr dom))
(shr-generic (cdr dom)))
(when (and shr-target-id
(equal (cdr (assq :id (cdr dom))) shr-target-id))
+ ;; If the element was empty, we don't have anything to put the
+ ;; anchor on. So just insert a dummy character.
+ (when (= start (point))
+ (insert "*"))
(put-text-property start (1+ start) 'shr-target-id shr-target-id))
;; If style is set, then this node has set the color.
(when style
(cdr (assq 'color shr-stylesheet))
(cdr (assq 'background-color shr-stylesheet)))))))
-(defun shr-generic (cont)
- (dolist (sub cont)
- (cond
- ((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))
;; 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) ?>))
+ `(let ((char ,char))
+ (and (not (eq 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) ?<))
(setq shr-state nil)
(let (found)
(while (and (> (current-column) shr-width)
+ (> shr-width 0)
(progn
(setq found (shr-find-fill-point))
(not (eolp))))
(when (> shr-indentation 0)
(shr-indent))
(end-of-line))
- (insert " ")))
+ (if (<= (current-column) shr-width)
+ (insert " ")
+ ;; In case we couldn't get a valid break point (because of a
+ ;; word that's longer than `shr-width'), just break anyway.
+ (insert "\n")
+ (when (> shr-indentation 0)
+ (shr-indent)))))
(unless (string-match "[ \t\r\n ]\\'" text)
(delete-char -1)))))
(backward-char 1))
(let ((bp (point))
failed)
- (while (not (or (setq failed (= (current-column) shr-indentation))
+ (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))))
+ (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))
+ (bolp)))
(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.
(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)))
+ (while (setq found (re-search-forward
+ "\\(\\c>\\)\\| \\|\\c<\\|\\c|"
+ (line-end-position) 'move)))
+ (if (and found
+ (not (match-beginning 1)))
(goto-char (match-beginning 0)))))
(or
(eolp)
(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))
+ (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
(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))))
+ (when (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))
(concat (nth 3 base) url))
(t
;; Totally relative.
- (concat (car base) (cadr base) url))))
+ (concat (car base) (expand-file-name url (cadr base))))))
(defun shr-ensure-newline ()
(unless (zerop (current-column))
(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))))
+ (let ((data (shr-parse-image-data)))
(with-current-buffer buffer
(save-excursion
(let ((alt (buffer-substring start end))
(setq payload (base64-decode-string payload)))
payload)))
-(defun shr-put-image (data alt &optional flags)
- "Put image DATA with a string ALT. Return image."
+;; Behind display-graphic-p test.
+(declare-function image-size "image.c" (spec &optional pixels frame))
+(declare-function image-animate "image" (image &optional index limit))
+
+(defun shr-put-image (spec alt &optional flags)
+ "Insert image SPEC with a string ALT. Return image.
+SPEC is either an image data blob, or a list where the first
+element is the data blob and the second element is the content-type."
(if (display-graphic-p)
(let* ((size (cdr (assq 'size flags)))
+ (data (if (consp spec)
+ (car spec)
+ spec))
+ (content-type (and (consp spec)
+ (cadr spec)))
(start (point))
(image (cond
((eq size 'original)
- (create-image data nil t :ascent 100))
+ (create-image data nil t :ascent 100
+ :format content-type))
((eq size 'full)
(ignore-errors
- (shr-rescale-image data t)))
+ (shr-rescale-image data content-type)))
(t
(ignore-errors
- (shr-rescale-image data))))))
+ (shr-rescale-image data content-type))))))
(when image
;; When inserting big-ish pictures, put them at the
;; beginning of the line.
(insert-sliced-image image (or alt "*") nil 20 1)
(insert-image image (or alt "*")))
(put-text-property start (point) 'image-size size)
- (when (cond ((fboundp 'image-multi-frame-p)
+ (when (and shr-image-animate
+ (cond ((fboundp 'image-multi-frame-p)
;; Only animate multi-frame things that specify a
;; delay; eg animated gifs as opposed to
;; multi-page tiffs. FIXME?
- (cdr (image-multi-frame-p image)))
- ((fboundp 'image-animated-p)
- (image-animated-p image)))
- (image-animate image nil 60)))
+ (cdr (image-multi-frame-p image)))
+ ((fboundp 'image-animated-p)
+ (image-animated-p image))))
+ (image-animate image nil 60)))
image)
(insert alt)))
-(defun shr-rescale-image (data &optional force)
- "Rescale DATA, if too big, to fit the current buffer.
-If FORCE, rescale the image anyway."
- (if (or (not (fboundp 'imagemagick-types))
- (eq (image-type-from-data data) 'gif)
- (not (get-buffer-window (current-buffer))))
+(defun shr-rescale-image (data &optional content-type)
+ "Rescale DATA, if too big, to fit the current buffer."
+ (if (not (and (fboundp 'imagemagick-types)
+ (get-buffer-window (current-buffer))))
(create-image data nil t :ascent 100)
(let ((edges (window-inside-pixel-edges
(get-buffer-window (current-buffer)))))
:max-width (truncate (* shr-max-image-proportion
(- (nth 2 edges) (nth 0 edges))))
:max-height (truncate (* shr-max-image-proportion
- (- (nth 3 edges) (nth 1 edges))))))))
+ (- (nth 3 edges) (nth 1 edges))))
+ :format content-type))))
;; url-cache-extract autoloads url-cache.
(declare-function url-cache-create-filename "url-cache" (url))
t)
(when (or (search-forward "\n\n" nil t)
(search-forward "\r\n\r\n" nil t))
- (buffer-substring (point) (point-max))))))
+ (shr-parse-image-data)))))
+
+(defun shr-parse-image-data ()
+ (list
+ (buffer-substring (point) (point-max))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (point-min) (point))
+ (let ((content-type (mail-fetch-field "content-type")))
+ (and content-type
+ (intern content-type obarray)))))))
(defun shr-image-displayer (content-function)
"Return a function to display an image.
(shr-ensure-paragraph))
(defun shr-urlify (start url &optional title)
- (when (and title (string-match "ctx" title)) (debug))
(shr-add-font start (point) 'shr-link)
(add-text-properties
start (point)
(shr-generic cont)
(shr-colorize-region start (point) fgcolor bgcolor)))
-(defun shr-tag-style (cont)
+(defun shr-tag-style (_cont)
)
-(defun shr-tag-script (cont)
+(defun shr-tag-script (_cont)
)
-(defun shr-tag-comment (cont)
+(defun shr-tag-comment (_cont)
)
(defun shr-dom-to-xml (dom)
"Convert DOM into a string containing the xml representation."
(let ((arg " ")
- (text ""))
+ (text "")
+ url)
(dolist (sub (cdr dom))
(cond
((listp (cdr sub))
- (setq text (concat text (shr-dom-to-xml sub))))
+ ;; Ignore external image definitions if required.
+ ;; <image xlink:href="http://TRACKING_URL/"/>
+ (when (or (not (eq (car sub) 'image))
+ (not (setq url (cdr (assq ':xlink:href (cdr sub)))))
+ (not shr-blocked-images)
+ (not (string-match shr-blocked-images url)))
+ (setq text (concat text (shr-dom-to-xml sub)))))
((eq (car sub) 'text)
(setq text (concat text (cdr sub))))
(t
(car dom))))
(defun shr-tag-svg (cont)
- (when (image-type-available-p 'svg)
+ (when (and (image-type-available-p 'svg)
+ (not shr-inhibit-images))
(funcall shr-put-image-function
(shr-dom-to-xml (cons 'svg cont))
"SVG Image")))
(start (point))
shr-start)
(shr-generic cont)
+ (when (and shr-target-id
+ (equal (cdr (assq :name cont)) shr-target-id))
+ ;; We have a zero-length <a name="foo"> element, so just
+ ;; insert... something.
+ (when (= start (point))
+ (shr-ensure-newline)
+ (insert " "))
+ (put-text-property start (1+ start) 'shr-target-id shr-target-id))
(when (and url
(not shr-inhibit-decoration))
(shr-urlify (or shr-start start) (shr-expand-url url) title))))
(shr-urlify start (shr-expand-url url)))
(shr-generic cont)))
+(defcustom shr-prefer-media-type-alist '(("webm" . 1.0)
+ ("ogv" . 1.0)
+ ("ogg" . 1.0)
+ ("opus" . 1.0)
+ ("flac" . 0.9)
+ ("wav" . 0.5))
+ "Preferences for media types.
+The key element should be a regexp matched against the type of the source or
+url if no type is specified. The value should be a float in the range 0.0 to
+1.0. Media elements with higher value are preferred."
+ :version "24.4"
+ :group 'shr
+ :type '(alist :key-type regexp :value-type float))
+
+(defun shr--get-media-pref (elem)
+ "Determine the preference for ELEM.
+The preference is a float determined from `shr-prefer-media-type'."
+ (let ((type (cdr (assq :type elem)))
+ (p 0.0))
+ (unless type
+ (setq type (cdr (assq :src elem))))
+ (when type
+ (dolist (pref shr-prefer-media-type-alist)
+ (when (and
+ (> (cdr pref) p)
+ (string-match-p (car pref) type))
+ (setq p (cdr pref)))))
+ p))
+
+(defun shr--extract-best-source (cont &optional url pref)
+ "Extract the best `:src' property from <source> blocks in CONT."
+ (setq pref (or pref -1.0))
+ (let (new-pref)
+ (dolist (elem cont)
+ (when (and (eq (car elem) 'source)
+ (< pref
+ (setq new-pref
+ (shr--get-media-pref elem))))
+ (setq pref new-pref
+ url (cdr (assq :src elem)))
+ ;; libxml's html parser isn't HTML5 compliant and non terminated
+ ;; source tags might end up as children. So recursion it is...
+ (dolist (child (cdr elem))
+ (when (eq (car child) 'source)
+ (let ((ret (shr--extract-best-source (list child) url pref)))
+ (when (< pref (cdr ret))
+ (setq url (car ret)
+ pref (cdr ret)))))))))
+ (cons url pref))
+
(defun shr-tag-video (cont)
(let ((image (cdr (assq :poster cont)))
- (url (cdr (assq :src cont)))
- (start (point)))
- (shr-tag-img nil image)
+ (url (cdr (assq :src cont)))
+ (start (point)))
+ (unless url
+ (setq url (car (shr--extract-best-source cont))))
+ (if image
+ (shr-tag-img nil image)
+ (shr-insert " [video] "))
+ (shr-urlify start (shr-expand-url url))))
+
+(defun shr-tag-audio (cont)
+ (let ((url (cdr (assq :src cont)))
+ (start (point)))
+ (unless url
+ (setq url (car (shr--extract-best-source cont))))
+ (shr-insert " [audio] ")
(shr-urlify start (shr-expand-url url))))
(defun shr-tag-img (cont &optional url)
(when (or url
(and cont
- (cdr (assq :src cont))))
+ (> (length (cdr (assq :src cont))) 0)))
(when (and (> (current-column) 0)
(not (eq shr-state 'image)))
(insert "\n"))
(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))
+ (put-text-property start (point) 'help-echo
+ (or (cdr (assq :title cont))
+ alt)))
(setq shr-state 'image)))))
(defun shr-tag-pre (cont)
(defun shr-tag-h6 (cont)
(shr-heading cont))
-(defun shr-tag-hr (cont)
+(defun shr-tag-hr (_cont)
(shr-ensure-newline)
(insert (make-string shr-width shr-hr-line) "\n"))
(if caption `((tr (td ,@caption))))
(if header
(if footer
- ;; hader + body + footer
+ ;; header + body + footer
(if (= nheader nbody)
(if (= nbody nfooter)
`((tr (td (table (tbody ,@header ,@body ,@footer)))))
HCoop / bpt / emacs.git / blobdiff