;;; shr.el --- Simple HTML Renderer
-;; Copyright (C) 2010-2012 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2013 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: html
"Images that have URLs matching this regexp will be blocked."
:version "24.1"
:group 'shr
- :type 'regexp)
+ :type '(choice (const nil) regexp))
(defcustom shr-table-horizontal-line ?\s
"Character used to draw horizontal table lines."
(const :tag "Use the width of the window" nil))
:group 'shr)
+(defcustom shr-bullet "* "
+ "Bullet used for unordered lists.
+Alternative suggestions are:
+- \" \"
+- \" \""
+ :type 'string
+ :group 'shr)
+
(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
(defvar shr-stylesheet nil)
(defvar shr-base nil)
(defvar shr-ignore-cache nil)
+(defvar shr-external-rendering-functions nil)
+(defvar shr-target-id 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: ")
+(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)
+ (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.
(shr-state nil)
(shr-start nil)
(shr-base nil)
+ (shr-preliminary-table-render 0)
(shr-width (or shr-width (window-width))))
(shr-descend (shr-transform-dom dom))
(shr-remove-trailing-whitespace start (point))))
(nreverse result)))
(defun shr-descend (dom)
- (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))
+ (let ((function
+ (or
+ ;; Allow other packages to override (or provide) rendering
+ ;; of elements.
+ (cdr (assq (car dom) shr-external-rendering-functions))
+ (intern (concat "shr-tag-" (symbol-name (car dom))) obarray)))
(style (cdr (assq :style (cdr dom))))
(shr-stylesheet shr-stylesheet)
(start (point)))
(when style
- (if (string-match "color" style)
+ (if (string-match "color\\|display" style)
(setq shr-stylesheet (nconc (shr-parse-style style)
shr-stylesheet))
(setq style nil)))
- (if (fboundp function)
- (funcall function (cdr dom))
- (shr-generic (cdr dom)))
- ;; If style is set, then this node has set the color.
- (when style
- (shr-colorize-region start (point)
- (cdr (assq 'color shr-stylesheet))
- (cdr (assq 'background-color shr-stylesheet))))))
+ ;; 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))
+ (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
+ (shr-colorize-region start (point)
+ (cdr (assq 'color shr-stylesheet))
+ (cdr (assq 'background-color shr-stylesheet)))))))
(defun shr-generic (cont)
(dolist (sub cont)
((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 "[ \f\t\n\r\v ]+" t))
+ (dolist (elem (split-string text "[ \f\t\n\r\v ]+" t))
(when (and (bolp)
(> shr-indentation 0))
(shr-indent))
(shr-indent))
(end-of-line))
(insert " ")))
- (unless (string-match "[ \t\n ]\\'" text)
+ (unless (string-match "[ \t\r\n ]\\'" text)
(delete-char -1)))))
(defun shr-find-fill-point ()
(forward-char 1))))
(not failed)))
-(defun shr-expand-url (url)
- (cond
- ;; Absolute URL.
- ((or (not url)
- (string-match "\\`[a-z]*:" url)
- (not shr-base))
- url)
- ((and (not (string-match "/\\'" shr-base))
- (not (string-match "\\`/" url)))
- (concat shr-base "/" url))
- (t
- (concat shr-base url))))
+(defun shr-parse-base (url)
+ ;; Always chop off anchors.
+ (when (string-match "#.*" url)
+ (setq url (substring url 0 (match-beginning 0))))
+ (let* ((parsed (url-generic-parse-url url))
+ (local (url-filename parsed)))
+ (setf (url-filename parsed) "")
+ ;; Chop off the bit after the last slash.
+ (when (string-match "\\`\\(.*/\\)[^/]+\\'" local)
+ (setq local (match-string 1 local)))
+ ;; Always make the local bit end with a slash.
+ (when (and (not (zerop (length local)))
+ (not (eq (aref local (1- (length local))) ?/)))
+ (setq local (concat local "/")))
+ (list (url-recreate-url parsed)
+ local
+ (url-type parsed)
+ url)))
+
+(defun shr-expand-url (url &optional base)
+ (setq base
+ (if base
+ (shr-parse-base base)
+ ;; Bound by the parser.
+ shr-base))
+ (when (zerop (length url))
+ (setq url nil))
+ (cond ((or (not url)
+ (not base)
+ (string-match "\\`[a-z]*:" url))
+ ;; Absolute URL.
+ (or url (car base)))
+ ((eq (aref url 0) ?/)
+ (if (and (> (length url) 1)
+ (eq (aref url 1) ?/))
+ ;; //host...; just use the protocol
+ (concat (nth 2 base) ":" url)
+ ;; Just use the host name part.
+ (concat (car base) url)))
+ ((eq (aref url 0) ?#)
+ ;; A link to an anchor.
+ (concat (nth 3 base) url))
+ (t
+ ;; Totally relative.
+ (concat (car base) (cadr base) url))))
(defun shr-ensure-newline ()
(unless (zerop (current-column))
(dolist (type types)
(shr-add-font (or shr-start (point)) (point) type))))
+(defun shr-make-overlay (beg end &optional buffer front-advance rear-advance)
+ (let ((overlay (make-overlay beg end buffer front-advance rear-advance)))
+ (overlay-put overlay 'evaporate t)
+ overlay))
+
;; 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.
(while (< (point) end)
(when (bolp)
(skip-chars-forward " "))
- (let ((overlay (make-overlay (point) (min (line-end-position) end))))
+ (let ((overlay (shr-make-overlay (point) (min (line-end-position) end))))
(overlay-put overlay 'face type))
(if (< (line-end-position) end)
(forward-line 1)
(put-text-property start (point) type value))))))))))
(kill-buffer image-buffer)))
+(defun shr-image-from-data (data)
+ "Return an image from the data: URI content DATA."
+ (when (string-match
+ "\\(\\([^/;,]+\\(/[^;,]+\\)?\\)\\(;[^;,]+\\)*\\)?,\\(.*\\)"
+ data)
+ (let ((param (match-string 4 data))
+ (payload (url-unhex-string (match-string 5 data))))
+ (when (string-match "^.*\\(;[ \t]*base64\\)$" param)
+ (setq payload (base64-decode-string payload)))
+ payload)))
+
(defun shr-put-image (data alt &optional flags)
"Put image DATA with a string ALT. Return image."
(if (display-graphic-p)
(overlay-put overlay 'face 'default)))
(insert-image image (or alt "*")))
(put-text-property start (point) 'image-size size)
- (when (image-animated-p image)
+ (when (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)))
image)
(insert alt)))
(when (and (< (setq column (current-column)) width)
(< (setq column (shr-previous-newline-padding-width column))
width))
- (let ((overlay (make-overlay (point) (1+ (point)))))
+ (let ((overlay (shr-make-overlay (point) (1+ (point)))))
(overlay-put overlay 'before-string
(concat
(mapconcat
(defun shr-tag-comment (cont)
)
+(defun shr-dom-to-xml (dom)
+ "Convert DOM into a string containing the xml representation."
+ (let ((arg " ")
+ (text ""))
+ (dolist (sub (cdr dom))
+ (cond
+ ((listp (cdr sub))
+ (setq text (concat text (shr-dom-to-xml sub))))
+ ((eq (car sub) 'text)
+ (setq text (concat text (cdr sub))))
+ (t
+ (setq arg (concat arg (format "%s=\"%s\" "
+ (substring (symbol-name (car sub)) 1)
+ (cdr sub)))))))
+ (format "<%s%s>%s</%s>"
+ (car dom)
+ (substring arg 0 (1- (length arg)))
+ text
+ (car dom))))
+
+(defun shr-tag-svg (cont)
+ (when (image-type-available-p 'svg)
+ (funcall shr-put-image-function
+ (shr-dom-to-xml (cons 'svg cont))
+ "SVG Image")))
+
(defun shr-tag-sup (cont)
(let ((start (point)))
(shr-generic cont)
(shr-fontize-cont cont 'italic))
(defun shr-tag-em (cont)
- (shr-fontize-cont cont 'bold))
+ (shr-fontize-cont cont 'italic))
(defun shr-tag-strong (cont)
(shr-fontize-cont cont 'bold))
plist)))
(defun shr-tag-base (cont)
- (setq shr-base (cdr (assq :href cont))))
+ (setq shr-base (shr-parse-base (cdr (assq :href cont))))
+ (shr-generic cont))
(defun shr-tag-a (cont)
(let ((url (cdr (assq :href cont)))
(start (point))
shr-start)
(shr-generic cont)
- (shr-urlify (or shr-start start) (shr-expand-url url) title)))
+ (when url
+ (shr-urlify (or shr-start start) (shr-expand-url url) title))))
(defun shr-tag-object (cont)
(let ((start (point))
(member (cdr (assq :width cont)) '("0" "1")))
;; Ignore zero-sized or single-pixel images.
)
+ ((and (not shr-inhibit-images)
+ (string-match "\\`data:" url))
+ (let ((image (shr-image-from-data (substring url (match-end 0)))))
+ (if image
+ (funcall shr-put-image-function image alt)
+ (insert alt))))
((and (not shr-inhibit-images)
(string-match "\\`cid:" url))
(let ((url (substring url (match-end 0)))
(shr-ensure-paragraph))
(defun shr-tag-li (cont)
- (shr-ensure-paragraph)
+ (shr-ensure-newline)
(shr-indent)
(let* ((bullet
(if (numberp shr-list-mode)
(prog1
(format "%d " shr-list-mode)
(setq shr-list-mode (1+ shr-list-mode)))
- "* "))
+ shr-bullet))
(shr-indentation (+ shr-indentation (length bullet))))
(insert bullet)
(shr-generic cont)))
(shr-indent))
(shr-generic cont))
+(defun shr-tag-span (cont)
+ (let ((title (cdr (assq :title cont))))
+ (shr-generic cont)
+ (when title
+ (when shr-start
+ (let ((overlay (shr-make-overlay shr-start (point))))
+ (overlay-put overlay 'help-echo title))))))
+
(defun shr-tag-h1 (cont)
(shr-heading cont 'bold 'underline))
(end-of-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)))
+ (let ((o (shr-make-overlay (- (point) (nth 0 overlay) 1)
+ (- (point) (nth 1 overlay) 1)))
(properties (nth 2 overlay)))
(while properties
(overlay-put o (pop properties) (pop properties)))))
(let ((end (length (car cache))))
(dolist (overlay (cadr cache))
(let ((new-overlay
- (make-overlay (1+ (- end (nth 0 overlay)))
- (1+ (- end (nth 1 overlay)))))
+ (shr-make-overlay (1+ (- end (nth 0 overlay)))
+ (1+ (- end (nth 1 overlay)))))
(properties (nth 2 overlay)))
(while properties
(overlay-put new-overlay
(provide 'shr)
+;; Local Variables:
+;; coding: utf-8
+;; End:
+
;;; shr.el ends here
projects / gnus / blobdiff