;;; 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
: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
(defun shr-insert-document (dom)
(setq shr-content-cache nil)
(let ((shr-state nil)
- (shr-start nil))
+ (shr-start nil)
+ (shr-width (or shr-width (window-width))))
(shr-descend (shr-transform-dom dom))))
(defun shr-copy-url ()
(style (cdr (assq :style (cdr dom))))
(shr-stylesheet shr-stylesheet)
(start (point)))
- (when (and style
- (string-match "color" style))
- (setq shr-stylesheet (nconc (shr-parse-style style)
- shr-stylesheet)))
+ (when style
+ (if (string-match "color" 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)))
- (let ((color (cdr (assq 'color shr-stylesheet)))
- (background (cdr (assq 'background-color
- shr-stylesheet))))
- (when (and shr-stylesheet
- (or color background))
- (shr-colorize-region start (point) color background)))))
+ ;; 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)
(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)
(if (eq (preceding-char) ?')
(not (memq (char-after (- (point) 2))
(list nil ?\n ? )))
- ;; There're some kinsoku CJK chars that aren't breakable.
(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))))
(backward-char 1))
(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)
+ (shr-put-image data alt)))))))
(kill-buffer (current-buffer)))
(defun shr-put-image (data alt)
(create-image data 'imagemagick t
:width window-width)
image)))
+ (when (and (fboundp 'create-animated-image)
+ (eq (image-type data nil t) 'gif))
+ (setq image (create-animated-image data 'gif t)))
image)))
;; url-cache-extract autoloads url-cache.
"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)
(when image
(goto-char start)
(shr-put-image image
- (prog1
- (buffer-substring-no-properties start end)
- (delete-region start end))))))
+ (buffer-substring-no-properties start end))
+ (delete-region (point) end))))
(url-retrieve url 'shr-image-fetched
(list (current-buffer) start end)
t)))))
(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)))))))
(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)
(let* ((old-props (get-text-property start 'face))
(shr-generic cont)
(shr-colorize-region start (point) fgcolor bgcolor)))
+(defun shr-tag-style (cont)
+ )
+
+(defun shr-tag-script (cont)
+ )
+
+(defun shr-tag-label (cont)
+ (shr-generic cont)
+ (shr-ensure-paragraph))
+
(defun shr-tag-p (cont)
(shr-ensure-paragraph)
(shr-indent)
(shr-heading cont 'bold 'underline))
(defun shr-tag-font (cont)
- (let ((start (point))
- (color (cdr (assq :color cont))))
+ (let* ((start (point))
+ (color (cdr (assq :color cont)))
+ (shr-stylesheet (nconc (list (cons 'color color))
+ shr-stylesheet)))
(shr-generic cont)
- (shr-colorize-region start (point) color)))
+ (when color
+ (shr-colorize-region start (point) color
+ (cdr (assq 'background-color shr-stylesheet))))))
;;; Table rendering algorithm.
(body (or (cdr (assq 'tbody cont)) cont))
(footer (cdr (assq 'tfoot cont)))
(bgcolor (cdr (assq :bgcolor cont)))
+ (start (point))
+ (shr-stylesheet (nconc (list (cons 'background-color bgcolor))
+ shr-stylesheet))
(nheader (if header (shr-max-columns header)))
(nbody (if body (shr-max-columns body)))
(nfooter (if footer (shr-max-columns footer))))
`((tr (td (table (tbody ,@footer))))))))
(if caption
`((tr (td (table (tbody ,@body)))))
- body)))))))
+ body)))))
+ (when bgcolor
+ (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
+ bgcolor))))
(defun shr-find-elements (cont type)
(let (result)
(defun shr-render-td (cont width fill)
(with-temp-buffer
- (let ((cache (cdr (assoc (cons width cont) shr-content-cache))))
- (if cache
- (insert cache)
- (let ((shr-width width)
- (shr-indentation 0))
- (shr-descend (cons 'td cont)))
- (delete-region
- (point)
- (+ (point)
- (skip-chars-backward " \t\n")))
- (push (cons (cons width cont) (buffer-string))
- shr-content-cache)))
- (goto-char (point-min))
- (let ((max 0))
- (while (not (eobp))
- (end-of-line)
- (setq max (max max (current-column)))
- (forward-line 1))
- (when fill
- (goto-char (point-min))
- ;; If the buffer is totally empty, then put a single blank
- ;; line here.
- (if (zerop (buffer-size))
- (insert (make-string width ? ))
- ;; Otherwise, fill the buffer.
- (while (not (eobp))
- (end-of-line)
- (when (> (- width (current-column)) 0)
- (insert (make-string (- width (current-column)) ? )))
- (forward-line 1))))
- (if fill
+ (let ((bgcolor (cdr (assq :bgcolor cont)))
+ (fgcolor (cdr (assq :fgcolor cont)))
+ (style (cdr (assq :style cont)))
+ (shr-stylesheet shr-stylesheet)
+ overlays)
+ (when style
+ (setq style (and (string-match "color" style)
+ (shr-parse-style style))))
+ (when bgcolor
+ (setq style (nconc (list (cons 'background-color bgcolor)) style)))
+ (when fgcolor
+ (setq style (nconc (list (cons 'color fgcolor)) style)))
+ (when style
+ (setq shr-stylesheet (append style shr-stylesheet)))
+ (let ((cache (cdr (assoc (cons width cont) shr-content-cache))))
+ (if cache
+ (progn
+ (insert (car cache))
+ (let ((end (length (car cache))))
+ (dolist (overlay (cadr cache))
+ (let ((new-overlay
+ (make-overlay (1+ (- end (nth 0 overlay)))
+ (1+ (- end (nth 1 overlay)))))
+ (properties (nth 2 overlay)))
+ (while properties
+ (overlay-put new-overlay
+ (pop properties) (pop properties)))))))
+ (let ((shr-width width)
+ (shr-indentation 0))
+ (shr-descend (cons 'td cont)))
+ (delete-region
+ (point)
+ (+ (point)
+ (skip-chars-backward " \t\n")))
+ (push (list (cons width cont) (buffer-string)
+ (shr-overlays-in-region (point-min) (point-max)))
+ shr-content-cache)))
+ (goto-char (point-min))
+ (let ((max 0))
+ (while (not (eobp))
+ (end-of-line)
+ (setq max (max max (current-column)))
+ (forward-line 1))
+ (when fill
+ (goto-char (point-min))
+ ;; If the buffer is totally empty, then put a single blank
+ ;; line here.
+ (if (zerop (buffer-size))
+ (insert (make-string width ? ))
+ ;; Otherwise, fill the buffer.
+ (while (not (eobp))
+ (end-of-line)
+ (when (> (- width (current-column)) 0)
+ (insert (make-string (- width (current-column)) ? )))
+ (forward-line 1))))
+ (when style
+ (shr-colorize-region
+ (point-min) (point-max)
+ (cdr (assq 'color shr-stylesheet))
+ (cdr (assq 'background-color shr-stylesheet))))
+ (if fill
+ (list max
+ (count-lines (point-min) (point-max))
+ (split-string (buffer-string) "\n")
+ (shr-collect-overlays))
(list max
- (count-lines (point-min) (point-max))
- (split-string (buffer-string) "\n")
- (shr-collect-overlays))
- (list max
- (shr-natural-width))))))
+ (shr-natural-width)))))))
(defun shr-natural-width ()
(goto-char (point-min))
projects / gnus / blobdiff