;;; 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
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))
:format content-type))
((eq size 'full)
(ignore-errors
- (shr-rescale-image data t content-type)))
+ (shr-rescale-image data content-type)))
(t
(ignore-errors
- (shr-rescale-image data nil content-type))))))
+ (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 content-type)
- "Rescale DATA, if too big, to fit the current buffer.
-If FORCE, rescale the image anyway."
- (if (or (not (fboundp 'imagemagick-types))
- (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)))))
(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")))
shr-start)
(shr-generic cont)
(when (and shr-target-id
- (equal (cdr (assq :name (cdr dom))) 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))
(setq pref (or pref -1.0))
(let (new-pref)
(dolist (elem cont)
- (when (and (listp elem)
- (not (keywordp (car elem)))) ;; skip attributes
- (when (and (eq (car elem) 'source)
- (< pref
- (setq new-pref
- (shr--get-media-pref elem))))
- (setq pref new-pref
- url (cdr (assq :src elem)))
- (message "new %s %s" url pref))
+ (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 (and (listp child)
- (not (keywordp (car child))) ;; skip attributes
- (eq (car child) 'source))
+ (when (eq (car child) 'source)
(let ((ret (shr--extract-best-source (list child) url pref)))
(when (< pref (cdr ret))
(setq url (car ret)
(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"))
HCoop / bpt / emacs.git / blobdiff