;;; Code:
+(eval-when-compile (require 'cl))
(require 'browse-url)
+(unless (aref (char-category-set (make-char 'japanese-jisx0208 33 35)) ?>)
+ (load "kinsoku" nil t))
(defgroup shr nil
"Simple HTML Renderer"
:group 'shr
:type 'regexp)
+(defcustom shr-table-line ?-
+ "Character used to draw table line."
+ :group 'shr
+ :type 'character)
+
+(defcustom shr-table-corner ?+
+ "Character used to draw table corner."
+ :group 'shr
+ :type 'character)
+
+(defcustom shr-hr-line ?-
+ "Character used to draw hr line."
+ :group 'shr
+ :type 'character)
+
+(defcustom shr-width fill-column
+ "Frame width to use for rendering."
+ :type 'integer
+ :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
cid: URL as the argument.")
-(defvar shr-width 70
- "Frame width to use for rendering.")
-
;;; Internal variables.
(defvar shr-folding-mode nil)
(defvar shr-indentation 0)
(defvar shr-inhibit-images nil)
(defvar shr-list-mode nil)
+(defvar shr-content-cache nil)
+(defvar shr-kinsoku-shorten nil)
(defvar shr-map
(let ((map (make-sparse-keymap)))
;;;###autoload
(defun shr-insert-document (dom)
+ (setq shr-content-cache nil)
(let ((shr-state nil)
(shr-start nil))
(shr-descend (shr-transform-dom dom))))
(message "Browsing %s..." url)
(browse-url url))))
+(defun shr-insert-image ()
+ "Insert the image under point into the buffer."
+ (interactive)
+ (let ((url (get-text-property (point) 'shr-image)))
+ (if (not url)
+ (message "No image under point")
+ (message "Inserting %s..." url)
+ (url-retrieve url 'shr-image-fetched
+ (list (current-buffer) (1- (point)) (point-marker))
+ t))))
+
;;; Utility functions.
(defun shr-transform-dom (dom)
(shr-descend sub)))))
(defun shr-insert (text)
- (when (eq shr-state 'image)
+ (when (and (eq shr-state 'image)
+ (not (string-match "\\`[ \t\n]+\\'" text)))
(insert "\n")
(setq shr-state nil))
(cond
((eq shr-folding-mode 'none)
(insert text))
(t
- (let ((first t)
- column)
- (when (and (string-match "\\`[ \t\n]" text)
- (not (bolp)))
- (insert " ")
- (setq shr-state 'space))
- (dolist (elem (split-string text))
- (setq column (current-column))
- (when (> column 0)
- (cond
- ((and (or (not first)
- (eq shr-state 'space))
- (> (+ column (length elem) 1) shr-width))
- (insert "\n"))
- ((not first)
- (insert " "))))
- (setq first nil)
- (when (and (bolp)
- (> shr-indentation 0))
+ (when (and (string-match "\\`[ \t\n]" text)
+ (not (bolp))
+ (not (eq (char-after (1- (point))) ? )))
+ (insert " "))
+ (dolist (elem (split-string text))
+ (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) ? )
+ (or (= (line-beginning-position) (1- (point)))
+ (and (aref fill-find-break-point-function-table
+ (setq prev (char-after (- (point) 2))))
+ (aref (char-category-set prev) ?>))
+ (and (aref fill-nospace-between-words-table prev)
+ (aref fill-nospace-between-words-table
+ (aref elem 0)))))
+ (delete-char -1)))
+ (insert elem)
+ (while (> (current-column) shr-width)
+ (unless (prog1
+ (shr-find-fill-point)
+ (when (eq (preceding-char) ? )
+ (delete-char -1))
+ (insert "\n"))
+ (put-text-property (1- (point)) (point) 'shr-break t)
+ ;; No space is needed at the beginning of a line.
+ (when (eq (following-char) ? )
+ (delete-char 1)))
+ (when (> 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)))
- (insert elem))
- (setq shr-state nil)
- (when (and (string-match "[ \t\n]\\'" text)
- (not (bolp)))
- (insert " ")
- (setq shr-state 'space))))))
+ (end-of-line))
+ (insert " "))
+ (unless (string-match "[ \t\n]\\'" text)
+ (delete-char -1)))))
+
+(defun shr-find-fill-point ()
+ (when (> (move-to-column shr-width) shr-width)
+ (backward-char 1))
+ (let (failed)
+ (while (not
+ (or (setq failed (= (current-column) shr-indentation))
+ (eq (preceding-char) ? )
+ (eq (following-char) ? )
+ (aref fill-find-break-point-function-table (preceding-char))))
+ (backward-char 1))
+ (if failed
+ ;; There's no breakable point, so we give it up.
+ (progn
+ (end-of-line)
+ (while (aref fill-find-break-point-function-table (preceding-char))
+ (backward-char 1))
+ nil)
+ (or (eolp)
+ ;; Don't put kinsoku-bol characters at the beginning of a line,
+ ;; or kinsoku-eol characters at the end of a line,
+ (let ((count 4))
+ (if shr-kinsoku-shorten
+ (while (and
+ (> count 0)
+ (or (aref (char-category-set (preceding-char)) ?<)
+ (aref (char-category-set (following-char)) ?>)))
+ (backward-char 1))
+ (while (and (> count 0)
+ (aref (char-category-set (following-char)) ?>))
+ (forward-char 1)))
+ (when (eq (following-char) ? )
+ (forward-char 1))
+ t)))))
(defun shr-ensure-newline ()
(unless (zerop (current-column))
(defun shr-ensure-paragraph ()
(unless (bobp)
- (if (bolp)
+ (if (<= (current-column) shr-indentation)
(unless (save-excursion
(forward-line -1)
(looking-at " *$"))
(insert "\n\n")))))
(defun shr-indent ()
- (insert (make-string shr-indentation ? )))
+ (when (> shr-indentation 0)
+ (insert (make-string shr-indentation ? ))))
(defun shr-fontize-cont (cont &rest types)
(let (shr-start)
(with-temp-buffer
(mm-disable-multibyte)
(when (ignore-errors
- (url-cache-extract (url-cache-create-filename url))
+ (url-cache-extract (url-cache-create-filename (shr-encode-url url)))
t)
(when (or (search-forward "\n\n" nil t)
(search-forward "\r\n\r\n" nil t))
(defun shr-tag-p (cont)
(shr-ensure-paragraph)
+ (shr-indent)
(shr-generic cont)
(shr-ensure-paragraph))
(defun shr-tag-s (cont)
(shr-fontize-cont cont 'strike-through))
+(defun shr-tag-span (cont)
+ (let ((start (point))
+ (color (cdr (assq 'color (shr-parse-style (cdr (assq :style cont)))))))
+ (shr-generic cont)
+ (when color
+ (let ((overlay (make-overlay start (point))))
+ (overlay-put overlay 'face (cons 'foreground-color color))))))
+
+(defun shr-parse-style (style)
+ (when style
+ (let ((plist nil))
+ (dolist (elem (split-string style ";"))
+ (when elem
+ (setq elem (split-string elem ":"))
+ (when (and (car elem)
+ (cadr elem))
+ (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem)))
+ (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem))))
+ (push (cons (intern name obarray)
+ value)
+ plist)))))
+ plist)))
+
(defun shr-tag-a (cont)
(let ((url (cdr (assq :href cont)))
(start (point))
shr-start)
(shr-generic cont)
(widget-convert-button
- 'link (or shr-start start) (point)
- :help-echo url)
- (put-text-property (or shr-start start) (point) 'keymap shr-map)
+ 'url-link (or shr-start start) (point)
+ :help-echo url
+ :keymap shr-map
+ url)
(put-text-property (or shr-start start) (point) 'shr-url url)))
+(defun shr-encode-url (url)
+ "Encode URL."
+ (browse-url-url-encode-chars url "[)$ ]"))
+
(defun shr-tag-img (cont)
- (when (and (> (current-column) 0)
- (not (eq shr-state 'image)))
- (insert "\n"))
- (let ((start (point-marker)))
+ (when cont
+ (when (and (> (current-column) 0)
+ (not (eq shr-state 'image)))
+ (insert "\n"))
(let ((alt (cdr (assq :alt cont)))
(url (cdr (assq :src cont))))
- (when (zerop (length alt))
- (setq alt "[img]"))
- (cond
- ((and (not shr-inhibit-images)
- (string-match "\\`cid:" url))
- (let ((url (substring url (match-end 0)))
- image)
- (if (or (not shr-content-function)
- (not (setq image (funcall shr-content-function url))))
- (insert alt)
- (shr-put-image image (point) alt))))
- ((or shr-inhibit-images
- (and shr-blocked-images
- (string-match shr-blocked-images url)))
- (setq shr-start (point))
- (let ((shr-state 'space))
- (if (> (length alt) 8)
- (shr-insert (substring alt 0 8))
- (shr-insert alt))))
- ((url-is-cached (browse-url-url-encode-chars url "[&)$ ]"))
- (shr-put-image (shr-get-image-data url) (point) alt))
- (t
- (insert alt)
- (ignore-errors
- (url-retrieve url 'shr-image-fetched
- (list (current-buffer) start (point-marker))
- t))))
- (insert " ")
- (put-text-property start (point) 'keymap shr-map)
- (put-text-property start (point) 'shr-alt alt)
- (put-text-property start (point) 'shr-image url)
- (setq shr-state 'image))))
+ (let ((start (point-marker)))
+ (when (zerop (length alt))
+ (setq alt "[img]"))
+ (cond
+ ((and (not shr-inhibit-images)
+ (string-match "\\`cid:" url))
+ (let ((url (substring url (match-end 0)))
+ image)
+ (if (or (not shr-content-function)
+ (not (setq image (funcall shr-content-function url))))
+ (insert alt)
+ (shr-put-image image (point) alt))))
+ ((or shr-inhibit-images
+ (and shr-blocked-images
+ (string-match shr-blocked-images url)))
+ (setq shr-start (point))
+ (let ((shr-state 'space))
+ (if (> (length alt) 8)
+ (shr-insert (substring alt 0 8))
+ (shr-insert alt))))
+ ((url-is-cached (shr-encode-url url))
+ (shr-put-image (shr-get-image-data url) (point) alt))
+ (t
+ (insert alt)
+ (ignore-errors
+ (url-retrieve (shr-encode-url url) 'shr-image-fetched
+ (list (current-buffer) start (point-marker))
+ t))))
+ (insert " ")
+ (put-text-property start (point) 'keymap shr-map)
+ (put-text-property start (point) 'shr-alt alt)
+ (put-text-property start (point) 'shr-image url)
+ (setq shr-state 'image)))))
(defun shr-tag-pre (cont)
(let ((shr-folding-mode 'none))
(shr-ensure-newline)
+ (shr-indent)
(shr-generic cont)
(shr-ensure-newline)))
(defun shr-tag-blockquote (cont)
(shr-ensure-paragraph)
+ (shr-indent)
(let ((shr-indentation (+ shr-indentation 4)))
(shr-generic cont))
(shr-ensure-paragraph))
(defun shr-tag-ul (cont)
(shr-ensure-paragraph)
(let ((shr-list-mode 'ul))
- (shr-generic cont)))
+ (shr-generic cont))
+ (shr-ensure-paragraph))
(defun shr-tag-ol (cont)
+ (shr-ensure-paragraph)
(let ((shr-list-mode 1))
- (shr-generic cont)))
+ (shr-generic cont))
+ (shr-ensure-paragraph))
(defun shr-tag-li (cont)
- (shr-ensure-newline)
+ (shr-ensure-paragraph)
+ (shr-indent)
(let* ((bullet
(if (numberp shr-list-mode)
(prog1
(defun shr-tag-br (cont)
(unless (bobp)
- (insert "\n"))
+ (insert "\n")
+ (shr-indent))
(shr-generic cont))
(defun shr-tag-h1 (cont)
(defun shr-tag-h6 (cont)
(shr-heading cont))
+(defun shr-tag-hr (cont)
+ (shr-ensure-newline)
+ (insert (make-string shr-width shr-hr-line) "\n"))
+
;;; Table rendering algorithm.
;; Table rendering is the only complicated thing here. We do this by
(setq cont (or (cdr (assq 'tbody cont))
cont))
(let* ((shr-inhibit-images t)
+ (shr-kinsoku-shorten t)
;; Find all suggested widths.
(columns (shr-column-specs cont))
;; Compute how many characters wide each TD should be.
;; be smaller (if there's little text) or bigger (if there's
;; unbreakable text).
(sketch (shr-make-table cont suggested-widths))
- (sketch-widths (shr-table-widths sketch (length suggested-widths))))
+ (sketch-widths (shr-table-widths sketch suggested-widths)))
+ ;; This probably won't work very well.
+ (when (> (+ (loop for width across sketch-widths
+ summing (1+ width))
+ shr-indentation 1)
+ (frame-width))
+ (setq truncate-lines t))
;; Then render the table again with these new "hard" widths.
(shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths))
;; Finally, insert all the images after the table. The Emacs buffer
(insert "|\n"))
(dolist (column row)
(goto-char start)
- (let ((lines (split-string (nth 2 column) "\n"))
+ (let ((lines (nth 2 column))
(overlay-lines (nth 3 column))
overlay overlay-line)
(dolist (line lines)
(setq overlay-line (pop overlay-lines))
- (when (> (length line) 0)
- (end-of-line)
- (insert line "|")
- (dolist (overlay overlay-line)
- (let ((o (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)))))
- (forward-line 1)))
+ (end-of-line)
+ (insert line "|")
+ (dolist (overlay overlay-line)
+ (let ((o (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)))))
+ (forward-line 1))
;; Add blank lines at padding at the bottom of the TD,
;; possibly.
(dotimes (i (- height (length lines)))
(end-of-line)
- (insert (make-string (length (car lines)) ? ) "|")
+ (insert (make-string (string-width (car lines)) ? ) "|")
(forward-line 1)))))
(shr-insert-table-ruler widths)))
(defun shr-insert-table-ruler (widths)
- (shr-indent)
- (insert "+")
+ (when (and (bolp)
+ (> shr-indentation 0))
+ (shr-indent))
+ (insert shr-table-corner)
(dotimes (i (length widths))
- (insert (make-string (aref widths i) ?-) ?+))
+ (insert (make-string (aref widths i) shr-table-line) shr-table-corner))
(insert "\n"))
-(defun shr-table-widths (table length)
- (let ((widths (make-vector length 0)))
+(defun shr-table-widths (table suggested-widths)
+ (let* ((length (length suggested-widths))
+ (widths (make-vector length 0))
+ (natural-widths (make-vector length 0)))
(dolist (row table)
(let ((i 0))
(dolist (column row)
(aset widths i (max (aref widths i)
(car column)))
- (incf i))))
+ (aset natural-widths i (max (aref natural-widths i)
+ (cadr column)))
+ (setq i (1+ i)))))
+ (let ((extra (- (apply '+ (append suggested-widths nil))
+ (apply '+ (append widths nil))))
+ (expanded-columns 0))
+ (when (> extra 0)
+ (dotimes (i length)
+ ;; If the natural width is wider than the rendered width, we
+ ;; want to allow the column to expand.
+ (when (> (aref natural-widths i) (aref widths i))
+ (setq expanded-columns (1+ expanded-columns))))
+ (dotimes (i length)
+ (when (> (aref natural-widths i) (aref widths i))
+ (aset widths i (min
+ (1+ (aref natural-widths i))
+ (+ (/ extra expanded-columns)
+ (aref widths i))))))))
widths))
(defun shr-make-table (cont widths &optional fill)
(defun shr-render-td (cont width fill)
(with-temp-buffer
- (let ((shr-width width)
- (shr-indentation 0))
- (shr-generic cont))
- (delete-region
- (point)
- (+ (point)
- (skip-chars-backward " \t\n")))
+ (let ((cache (cdr (assoc (cons width cont) shr-content-cache))))
+ (if cache
+ (insert cache)
+ (let ((shr-width width)
+ (shr-indentation 0))
+ (shr-generic 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))
(when (> (- width (current-column)) 0)
(insert (make-string (- width (current-column)) ? )))
(forward-line 1))))
- (list max
- (count-lines (point-min) (point-max))
- (buffer-string)
- (and fill
- (shr-collect-overlays))))))
+ (if fill
+ (list max
+ (count-lines (point-min) (point-max))
+ (split-string (buffer-string) "\n")
+ (shr-collect-overlays))
+ (list max
+ (shr-natural-width))))))
+
+(defun shr-natural-width ()
+ (goto-char (point-min))
+ (let ((current 0)
+ (max 0))
+ (while (not (eobp))
+ (end-of-line)
+ (setq current (+ current (current-column)))
+ (unless (get-text-property (point) 'shr-break)
+ (setq max (max max current)
+ current 0))
+ (forward-line 1))
+ max))
(defun shr-collect-overlays ()
(save-excursion
(let ((total-percentage 0)
(widths (make-vector (length columns) 0)))
(dotimes (i (length columns))
- (incf total-percentage (aref columns i)))
+ (setq total-percentage (+ total-percentage (aref columns i))))
(setq total-percentage (/ 1.0 total-percentage))
(dotimes (i (length columns))
(aset widths i (max (truncate (* (aref columns i)
total-percentage
- shr-width))
+ (- shr-width (1+ (length columns)))))
10)))
widths))
projects / gnus / blobdiff