:group 'shr
:type '(choice (const nil) regexp))
-(defcustom shr-table-horizontal-line ?\s
- "Character used to draw horizontal table lines."
+(defcustom shr-table-horizontal-line nil
+ "Character used to draw horizontal table lines.
+If nil, don't draw horizontal table lines."
:group 'shr
:type 'character)
(defvar shr-ignore-cache nil)
(defvar shr-external-rendering-functions nil)
(defvar shr-target-id nil)
+(defvar shr-inhibit-decoration nil)
+(defvar shr-table-separator-length 1)
(defvar shr-map
(let ((map (make-sparse-keymap)))
(define-key map "z" 'shr-zoom-image)
(define-key map [tab] 'shr-next-link)
(define-key map [backtab] 'shr-previous-link)
+ (define-key map [follow-link] 'mouse-face)
(define-key map "I" 'shr-insert-image)
(define-key map "u" 'shr-copy-url)
(define-key map "v" 'shr-browse-url)
map))
;; Public functions and commands.
+(declare-function libxml-parse-html-region "xml.c"
+ (start end &optional base-url))
(defun shr-render-buffer (buffer)
"Display the HTML rendering of the current buffer."
(interactive (list (current-buffer)))
+ (or (fboundp 'libxml-parse-html-region)
+ (error "This function requires Emacs to be compiled with libxml2"))
(pop-to-buffer "*html*")
(erase-buffer)
(shr-insert-document
(shr-start nil)
(shr-base nil)
(shr-preliminary-table-render 0)
- (shr-width (or shr-width (window-width))))
+ (shr-width (or shr-width (1- (window-width)))))
(shr-descend (shr-transform-dom dom))
(shr-remove-trailing-whitespace start (point))))
(defun shr-next-link ()
"Skip to the next link."
(interactive)
- (let ((skip (text-property-any (point) (point-max) 'shr-url nil)))
+ (let ((skip (text-property-any (point) (point-max) 'help-echo nil)))
(if (not (setq skip (text-property-not-all skip (point-max)
- 'shr-url nil)))
+ 'help-echo nil)))
(message "No next link")
(goto-char skip)
(message "%s" (get-text-property (point) 'help-echo)))))
(found nil))
;; Skip past the current link.
(while (and (not (bobp))
- (get-text-property (point) 'shr-url))
+ (get-text-property (point) 'help-echo))
(forward-char -1))
;; Find the previous link.
(while (and (not (bobp))
- (not (setq found (get-text-property (point) 'shr-url))))
+ (not (setq found (get-text-property (point) 'help-echo))))
(forward-char -1))
(if (not found)
(progn
(goto-char start))
;; Put point at the start of the link.
(while (and (not (bobp))
- (get-text-property (point) 'shr-url))
+ (get-text-property (point) 'help-echo))
(forward-char -1))
(forward-char 1)
(message "%s" (get-text-property (point) 'help-echo)))))
(shr-stylesheet shr-stylesheet)
(start (point)))
(when style
- (if (string-match "color\\|display" style)
+ (if (string-match "color\\|display\\|border-collapse" style)
(setq shr-stylesheet (nconc (shr-parse-style style)
shr-stylesheet))
(setq style nil)))
(insert "\n"))
(if (save-excursion
(beginning-of-line)
- (looking-at " *$"))
+ ;; If the current line is totally blank, and doesn't even
+ ;; have any face properties set, then delete the blank
+ ;; space.
+ (and (looking-at " *$")
+ (not (get-text-property (point) 'face))
+ (not (= (next-single-property-change (point) 'face nil
+ (line-end-position))
+ (line-end-position)))))
(delete-region (match-beginning 0) (match-end 0))
(insert "\n\n")))))
(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 face to 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.
(defun shr-add-font (start end type)
- (save-excursion
- (goto-char start)
- (while (< (point) end)
- (when (bolp)
- (skip-chars-forward " "))
- (add-face-text-property (point) (min (line-end-position) end) type t)
- (if (< (line-end-position) end)
- (forward-line 1)
- (goto-char end)))))
+ (unless shr-inhibit-decoration
+ (save-excursion
+ (goto-char start)
+ (while (< (point) end)
+ (when (bolp)
+ (skip-chars-forward " "))
+ (add-face-text-property (point) (min (line-end-position) end) type t)
+ (if (< (line-end-position) end)
+ (forward-line 1)
+ (goto-char end))))))
(defun shr-browse-url ()
"Browse the URL under point."
(shr-ensure-paragraph))
(defun shr-urlify (start url &optional title)
+ (when (and title (string-match "ctx" title)) (debug))
(shr-add-font start (point) 'shr-link)
(add-text-properties
start (point)
(list 'shr-url url
- 'local-map shr-map
- 'help-echo (if title (format "%s (%s)" url title) url))))
+ 'help-echo (if title (format "%s (%s)" url title) url)
+ 'keymap shr-map)))
(defun shr-encode-url (url)
"Encode URL."
(shr-color-visible bg fg)))))))
(defun shr-colorize-region (start end fg &optional bg)
- (when (or fg bg)
+ (when (and (not shr-inhibit-decoration)
+ (or fg bg))
(let ((new-colors (shr-color-check fg bg)))
(when new-colors
(when fg
- (shr-add-font start end (list :foreground (cadr new-colors))))
+ (add-face-text-property start end
+ (list :foreground (cadr new-colors))
+ t))
(when bg
- (shr-add-font start end (list :background (car new-colors)))))
+ (add-face-text-property start end
+ (list :background (car new-colors))
+ t)))
new-colors)))
(defun shr-expand-newlines (start end color)
plist)))
(defun shr-tag-base (cont)
- (setq shr-base (shr-parse-base (cdr (assq :href cont))))
+ (let ((base (cdr (assq :href cont))))
+ (when base
+ (setq shr-base (shr-parse-base base))))
(shr-generic cont))
(defun shr-tag-a (cont)
(start (point))
shr-start)
(shr-generic cont)
- (when url
+ (when (and url
+ (not shr-inhibit-decoration))
(shr-urlify (or shr-start start) (shr-expand-url url) title))))
(defun shr-tag-object (cont)
(shr-generic cont))
(shr-ensure-paragraph))
+(defun shr-tag-dl (cont)
+ (shr-ensure-paragraph)
+ (shr-generic cont)
+ (shr-ensure-paragraph))
+
+(defun shr-tag-dt (cont)
+ (shr-ensure-newline)
+ (shr-generic cont)
+ (shr-ensure-newline))
+
+(defun shr-tag-dd (cont)
+ (shr-ensure-newline)
+ (let ((shr-indentation (+ shr-indentation 4)))
+ (shr-generic cont)))
+
(defun shr-tag-ul (cont)
(shr-ensure-paragraph)
(let ((shr-list-mode 'ul))
(shr-generic cont))
(defun shr-tag-span (cont)
- (let ((title (cdr (assq :title cont))))
- (shr-generic cont)
- (when (and title
- shr-start)
- (put-text-property shr-start (point) 'help-echo title))))
+ (shr-generic cont))
(defun shr-tag-h1 (cont)
(shr-heading cont 'bold 'underline))
(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
- ;; model isn't strong enough to allow us to put the images actually
- ;; into the tables.
- (when (zerop shr-table-depth)
- (dolist (elem (shr-find-elements cont 'img))
- (shr-tag-img (cdr elem)))))
+ (shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths)))
(defun shr-tag-table (cont)
(shr-ensure-paragraph)
body))))))
(when bgcolor
(shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
- bgcolor))))
+ bgcolor))
+ ;; Finally, insert all the images after the table. The Emacs buffer
+ ;; model isn't strong enough to allow us to put the images actually
+ ;; into the tables.
+ (when (zerop shr-table-depth)
+ (dolist (elem (shr-find-elements cont 'img))
+ (shr-tag-img (cdr elem))))))
(defun shr-find-elements (cont type)
(let (result)
(nreverse result)))
(defun shr-insert-table (table widths)
- (shr-insert-table-ruler widths)
- (dolist (row table)
- (let ((start (point))
- (height (let ((max 0))
- (dolist (column row)
- (setq max (max max (cadr column))))
- max)))
- (dotimes (i height)
- (shr-indent)
- (insert shr-table-vertical-line "\n"))
- (dolist (column row)
- (goto-char start)
- (let ((lines (nth 2 column)))
- (dolist (line lines)
- (end-of-line)
- (insert line shr-table-vertical-line)
- (forward-line 1))
- ;; Add blank lines at padding at the bottom of the TD,
- ;; possibly.
- (dotimes (i (- height (length lines)))
- (end-of-line)
- (let ((start (point)))
- (insert (make-string (string-width (car lines)) ? )
- shr-table-vertical-line)
- (when (nth 4 column)
- (shr-add-font start (1- (point))
- (list :background (nth 4 column)))))
- (forward-line 1)))))
- (shr-insert-table-ruler widths)))
+ (let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet))
+ "collapse"))
+ (shr-table-separator-length (if collapse 0 1))
+ (shr-table-vertical-line (if collapse "" shr-table-vertical-line)))
+ (unless collapse
+ (shr-insert-table-ruler widths))
+ (dolist (row table)
+ (let ((start (point))
+ (height (let ((max 0))
+ (dolist (column row)
+ (setq max (max max (cadr column))))
+ max)))
+ (dotimes (i height)
+ (shr-indent)
+ (insert shr-table-vertical-line "\n"))
+ (dolist (column row)
+ (goto-char start)
+ (let ((lines (nth 2 column)))
+ (dolist (line lines)
+ (end-of-line)
+ (insert line shr-table-vertical-line)
+ (forward-line 1))
+ ;; Add blank lines at padding at the bottom of the TD,
+ ;; possibly.
+ (dotimes (i (- height (length lines)))
+ (end-of-line)
+ (let ((start (point)))
+ (insert (make-string (string-width (car lines)) ? )
+ shr-table-vertical-line)
+ (when (nth 4 column)
+ (shr-add-font start (1- (point))
+ (list :background (nth 4 column)))))
+ (forward-line 1)))))
+ (unless collapse
+ (shr-insert-table-ruler widths)))))
(defun shr-insert-table-ruler (widths)
- (when (and (bolp)
- (> shr-indentation 0))
- (shr-indent))
- (insert shr-table-corner)
- (dotimes (i (length widths))
- (insert (make-string (aref widths i) shr-table-horizontal-line)
- shr-table-corner))
- (insert "\n"))
+ (when shr-table-horizontal-line
+ (when (and (bolp)
+ (> shr-indentation 0))
+ (shr-indent))
+ (insert shr-table-corner)
+ (dotimes (i (length widths))
+ (insert (make-string (aref widths i) shr-table-horizontal-line)
+ shr-table-corner))
+ (insert "\n")))
(defun shr-table-widths (table natural-table suggested-widths)
(let* ((length (length suggested-widths))
data)))
(defun shr-make-table-1 (cont widths &optional fill)
- (let ((trs nil))
+ (let ((trs nil)
+ (shr-inhibit-decoration (not fill))
+ (rowspans (make-vector (length widths) 0))
+ width colspan)
(dolist (row cont)
(when (eq (car row) 'tr)
(let ((tds nil)
(columns (cdr row))
(i 0)
+ (width-column 0)
column)
(while (< i (length widths))
- (setq column (pop columns))
+ ;; If we previously had a rowspan definition, then that
+ ;; means that we now have a "missing" td/th element here.
+ ;; So just insert a dummy, empty one to (sort of) emulate
+ ;; rowspan.
+ (setq column
+ (if (zerop (aref rowspans i))
+ (pop columns)
+ (aset rowspans i (1- (aref rowspans i)))
+ '(td)))
(when (or (memq (car column) '(td th))
- (null column))
- (push (shr-render-td (cdr column) (aref widths i) fill)
- tds)
- (setq i (1+ i))))
+ (not column))
+ (when (cdr (assq :rowspan (cdr column)))
+ (aset rowspans i (+ (aref rowspans i)
+ (1- (string-to-number
+ (cdr (assq :rowspan (cdr column))))))))
+ (setq width
+ (if column
+ (aref widths width-column)
+ 0))
+ (when (and fill
+ (setq colspan (cdr (assq :colspan (cdr column)))))
+ (setq colspan (string-to-number colspan))
+ (dotimes (j (1- colspan))
+ (if (> (+ i 1 j) (1- (length widths)))
+ (setq width (aref widths (1- (length widths))))
+ (setq width (+ width
+ shr-table-separator-length
+ (aref widths (+ i 1 j))))))
+ (setq width-column (+ width-column (1- colspan))))
+ (when (or column
+ (not fill))
+ (push (shr-render-td (cdr column) width fill)
+ tds))
+ (setq i (1+ i)
+ width-column (1+ width-column))))
(push (nreverse tds) trs))))
(nreverse trs)))
(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)))
+ (let ((align (cdr (assq :align cont)))
+ length)
+ (while (not (eobp))
+ (end-of-line)
+ (setq length (- width (current-column)))
+ (when (> length 0)
+ (cond
+ ((equal align "right")
+ (beginning-of-line)
+ (insert (make-string length ? )))
+ ((equal align "center")
+ (insert (make-string (/ length 2) ? ))
+ (beginning-of-line)
+ (insert (make-string (- length (/ length 2)) ? )))
+ (t
+ (insert (make-string length ? )))))
+ (forward-line 1))))
(when style
(setq actual-colors
(shr-colorize-region
projects / gnus / blobdiff