;;; shr.el --- Simple HTML Renderer
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: html
:group 'shr
:type 'regexp)
-(defcustom shr-table-horizontal-line ?-
+(defcustom shr-table-horizontal-line ?
"Character used to draw horizontal table lines."
:group 'shr
:type 'character)
-(defcustom shr-table-vertical-line ?|
+(defcustom shr-table-vertical-line ?
"Character used to draw vertical table lines."
:group 'shr
:type 'character)
-(defcustom shr-table-corner ?+
+(defcustom shr-table-corner ?
"Character used to draw table corners."
:group 'shr
:type 'character)
:type 'character)
(defcustom shr-width fill-column
- "Frame width to use for rendering."
- :type 'integer
+ "Frame width to use for rendering.
+May either be an integer specifying a fixed width in characters,
+or nil, meaning that the full width of the window should be
+used."
+ :type '(choice (integer :tag "Fixed width in characters")
+ (const :tag "Use the width of the window" nil))
:group 'shr)
(defvar shr-content-function nil
This is used for cid: URLs, and the function is called with the
cid: URL as the argument.")
+(defvar shr-put-image-function 'shr-put-image
+ "Function called to put image and alt string.")
+
+(defface shr-strike-through '((t (:strike-through t)))
+ "Font for <s> elements."
+ :group 'shr)
+
+(defface shr-link
+ '((t (:inherit link)))
+ "Font for link elements."
+ :group 'shr)
+
;;; Internal variables.
(defvar shr-folding-mode nil)
(defvar shr-kinsoku-shorten nil)
(defvar shr-table-depth 0)
(defvar shr-stylesheet nil)
+(defvar shr-base nil)
(defvar shr-map
(let ((map (make-sparse-keymap)))
;; Public functions and commands.
+(defun shr-visit-file (file)
+ (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)))))
+
;;;###autoload
(defun shr-insert-document (dom)
(setq shr-content-cache nil)
(let ((shr-state nil)
- (shr-start nil))
+ (shr-start nil)
+ (shr-base nil)
+ (shr-width (or shr-width (window-width))))
(shr-descend (shr-transform-dom dom))))
(defun shr-copy-url ()
(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."
(when (and (bolp)
(> shr-indentation 0))
(shr-indent))
- ;; The shr-start is a special variable that is used to pass
- ;; upwards the first point in the buffer where the text really
- ;; starts.
- (unless shr-start
- (setq shr-start (point)))
;; No space is needed behind a wide character categorized as
;; kinsoku-bol, between characters both categorized as nospace,
;; or at the beginning of a line.
(let (prev)
- (when (and (eq (preceding-char) ? )
+ (when (and (> (current-column) shr-indentation)
+ (eq (preceding-char) ? )
(or (= (line-beginning-position) (1- (point)))
(and (shr-char-breakable-p
(setq prev (char-after (- (point) 2))))
(and (shr-char-nospace-p prev)
(shr-char-nospace-p (aref elem 0)))))
(delete-char -1)))
+ ;; The shr-start is a special variable that is used to pass
+ ;; upwards the first point in the buffer where the text really
+ ;; starts.
+ (unless shr-start
+ (setq shr-start (point)))
(insert elem)
(let (found)
(while (and (> (current-column) shr-width)
(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-ensure-newline ()
(unless (zerop (current-column))
(insert "\n")))
(search-forward "\r\n\r\n" nil t))
(let ((data (buffer-substring (point) (point-max))))
(with-current-buffer buffer
- (let ((alt (buffer-substring start end))
- (inhibit-read-only t))
- (delete-region start end)
- (goto-char start)
- (shr-put-image data alt))))))
+ (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)
+ "Put image DATA with a string ALT. Return image."
(if (display-graphic-p)
(let ((image (ignore-errors
(shr-rescale-image data))))
(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))
+ (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))
(when (> (car size) window-width)
(setq image (or
(create-image data 'imagemagick t
- :width window-width)
+ :width window-width
+ :ascent 100)
image)))
image)))
"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."
+START, and END. Note that START and END should be merkers."
`(lambda (url start end)
(when url
(if (string-match "\\`cid:" url)
(substring url (match-end 0)))))
(when image
(goto-char start)
- (shr-put-image image
- (prog1
- (buffer-substring-no-properties start end)
- (delete-region start end))))))
+ (funcall shr-put-image-function
+ image (buffer-substring start end))
+ (delete-region (point) end))))
(url-retrieve url 'shr-image-fetched
(list (current-buffer) start end)
t)))))
:help-echo (if title (format "%s (%s)" url title) url)
:keymap shr-map
url)
+ (shr-add-font start (point) 'shr-link)
(put-text-property start (point) 'shr-url url))
(defun shr-encode-url (url)
(when (or fg bg)
(let ((new-colors (shr-color-check fg bg)))
(when new-colors
- (shr-put-color start end :foreground (cadr new-colors))
+ (when fg
+ (shr-put-color start end :foreground (cadr new-colors)))
(when bg
- (shr-put-color start end :background (car new-colors)))))))
+ (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
(save-excursion
(goto-char start)
(while (< (point) end)
- (when (bolp)
+ (when (and (bolp)
+ (not (eq type :background)))
(skip-chars-forward " "))
(when (> (line-end-position) (point))
(shr-put-color-1 (point) (min (line-end-position) end) type color))
(if (< (line-end-position) end)
(forward-line 1)
- (goto-char end)))))
+ (goto-char end)))
+ (when (and (eq type :background)
+ (= shr-table-depth 0))
+ (shr-expand-newlines start end color))))
+
+(defun shr-expand-newlines (start end color)
+ (save-restriction
+ ;; Skip past all white space at the start and ends.
+ (goto-char start)
+ (skip-chars-forward " \t\n")
+ (beginning-of-line)
+ (setq start (point))
+ (goto-char end)
+ (skip-chars-backward " \t\n")
+ (forward-line 1)
+ (setq end (point))
+ (narrow-to-region start end)
+ (let ((width (shr-natural-width))
+ column)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (end-of-line)
+ (when (and (< (setq column (current-column)) width)
+ (< (setq column (shr-previous-newline-padding-width column))
+ width))
+ (let ((overlay (make-overlay (point) (1+ (point)))))
+ (overlay-put overlay 'before-string
+ (concat
+ (mapconcat
+ (lambda (overlay)
+ (let ((string (plist-get
+ (overlay-properties overlay)
+ 'before-string)))
+ (if (not string)
+ ""
+ (overlay-put overlay 'before-string "")
+ string)))
+ (overlays-at (point))
+ "")
+ (propertize (make-string (- width column) ? )
+ 'face (list :background color))))))
+ (forward-line 1)))))
+
+(defun shr-previous-newline-padding-width (width)
+ (let ((overlays (overlays-at (point)))
+ (previous-width 0))
+ (if (null overlays)
+ width
+ (dolist (overlay overlays)
+ (setq previous-width
+ (+ previous-width
+ (length (plist-get (overlay-properties overlay)
+ 'before-string)))))
+ (+ width previous-width))))
(defun shr-put-color-1 (start end type color)