;;; Code:
(eval-when-compile (require 'cl))
+(eval-when-compile (require 'url)) ;For url-filename's setf handler.
(require 'browse-url)
(defgroup shr nil
: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)
(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-base nil)
(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 "a" 'shr-show-alt-text)
(define-key map "i" 'shr-browse-image)
(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))))
(copy-region-as-kill (point-min) (point-max))
(message "Copied %s" url))))))
+(defun shr-next-link ()
+ "Skip to the next link."
+ (interactive)
+ (let ((skip (text-property-any (point) (point-max) 'help-echo nil)))
+ (if (not (setq skip (text-property-not-all skip (point-max)
+ 'help-echo nil)))
+ (message "No next link")
+ (goto-char skip)
+ (message "%s" (get-text-property (point) 'help-echo)))))
+
+(defun shr-previous-link ()
+ "Skip to the previous link."
+ (interactive)
+ (let ((start (point))
+ (found nil))
+ ;; Skip past the current link.
+ (while (and (not (bobp))
+ (get-text-property (point) 'help-echo))
+ (forward-char -1))
+ ;; Find the previous link.
+ (while (and (not (bobp))
+ (not (setq found (get-text-property (point) 'help-echo))))
+ (forward-char -1))
+ (if (not found)
+ (progn
+ (message "No previous link")
+ (goto-char start))
+ ;; Put point at the start of the link.
+ (while (and (not (bobp))
+ (get-text-property (point) 'help-echo))
+ (forward-char -1))
+ (forward-char 1)
+ (message "%s" (get-text-property (point) 'help-echo)))))
+
(defun shr-show-alt-text ()
"Show the ALT text of the image under point."
(interactive)
(shr-stylesheet shr-stylesheet)
(start (point)))
(when style
- (if (string-match "color" style)
+ (if (string-match "color\\|display\\|border-collapse" 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)
(not failed)))
(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) "")
(when (and (not (zerop (length local)))
(not (eq (aref local (1- (length local))) ?/)))
(setq local (concat local "/")))
- (cons (url-recreate-url parsed)
- local)))
+ (list (url-recreate-url parsed)
+ local
+ (url-type parsed)
+ url)))
(defun shr-expand-url (url &optional base)
(setq 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) ?/)
- ;; Just use the host name part.
- (concat (car base) url))
+ (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) (cdr base) url))))
+ (concat (car base) (cadr base) url))))
(defun shr-ensure-newline ()
(unless (zerop (current-column))
(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 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.
+;; 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 " "))
- (let ((overlay (shr-make-overlay (point) (min (line-end-position) end))))
- (overlay-put overlay 'face type))
- (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."
(> (car (image-size image t)) 400))
(insert "\n"))
(if (eq size 'original)
- (let ((overlays (overlays-at (point))))
- (insert-sliced-image image (or alt "*") nil 20 1)
- (dolist (overlay overlays)
- (overlay-put overlay 'face 'default)))
+ (insert-sliced-image image (or alt "*") nil 20 1)
(insert-image image (or alt "*")))
(put-text-property start (point) 'image-size size)
(when (cond ((fboundp 'image-multi-frame-p)
(apply #'shr-fontize-cont cont types)
(shr-ensure-paragraph))
-(autoload 'widget-convert-button "wid-edit")
-
(defun shr-urlify (start url &optional title)
- (widget-convert-button
- 'url-link start (point)
- :help-echo (if title (format "%s (%s)" url title) url)
- :keymap shr-map
- url)
+ (when (and title (string-match "ctx" title)) (debug))
(shr-add-font start (point) 'shr-link)
- (put-text-property start (point) 'shr-url url))
+ (add-text-properties
+ start (point)
+ (list 'shr-url 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-put-color start end :foreground (cadr new-colors)))
+ (add-face-text-property start end
+ (list :foreground (cadr new-colors))
+ t))
(when bg
- (shr-put-color start end :background (car new-colors))))
+ (add-face-text-property start end
+ (list :background (car new-colors))
+ t)))
new-colors)))
-;; 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
-;; to win.
-(defun shr-put-color (start end type color)
- (save-excursion
- (goto-char start)
- (while (< (point) end)
- (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)))
- (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.
(when (and (< (setq column (current-column)) width)
(< (setq column (shr-previous-newline-padding-width column))
width))
- (let ((overlay (shr-make-overlay (point) (1+ (point)))))
+ (let ((overlay (make-overlay (point) (1+ (point)))))
(overlay-put overlay 'before-string
(concat
(mapconcat
'before-string)))))
(+ width previous-width))))
-(defun shr-put-color-1 (start end type color)
- (let* ((old-props (get-text-property start 'face))
- (do-put (and (listp old-props)
- (not (memq type old-props))))
- change)
- (while (< start end)
- (setq change (next-single-property-change start 'face nil end))
- (when do-put
- (put-text-property start change 'face
- (nconc (list type color) old-props)))
- (setq old-props (get-text-property change 'face))
- (setq do-put (and (listp old-props)
- (not (memq type old-props))))
- (setq start change))
- (when (and do-put
- (> end start))
- (put-text-property start end 'face
- (nconc (list type color old-props))))))
-
;;; Tag-specific rendering rules.
(defun shr-tag-body (cont)
(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)))
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-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-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))))))
+ (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))
- (overlay-lines (nth 3 column))
- overlay overlay-line)
- (dolist (line lines)
- (setq overlay-line (pop overlay-lines))
- (end-of-line)
- (insert line shr-table-vertical-line)
- (dolist (overlay overlay-line)
- (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)))))
- (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-put-color start (1- (point)) :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))
widths))
(defun shr-make-table (cont widths &optional fill)
- (let ((trs nil))
+ (or (cadr (assoc (list cont widths fill) shr-content-cache))
+ (let ((data (shr-make-table-1 cont widths fill)))
+ (push (list (list cont widths fill) data)
+ shr-content-cache)
+ data)))
+
+(defun shr-make-table-1 (cont widths &optional fill)
+ (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)))
(fgcolor (cdr (assq :fgcolor cont)))
(style (cdr (assq :style cont)))
(shr-stylesheet shr-stylesheet)
- overlays actual-colors)
+ actual-colors)
(when style
(setq style (and (string-match "color" style)
(shr-parse-style style))))
(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
- (shr-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 padding at the bottom of the TDs.
- (delete-region
- (point)
- (progn
- (skip-chars-backward " \t\n")
- (end-of-line)
- (point)))
- (push (list (cons width cont) (buffer-string)
- (shr-overlays-in-region (point-min) (point-max)))
- shr-content-cache)))
+ (let ((shr-width width)
+ (shr-indentation 0))
+ (shr-descend (cons 'td cont)))
+ ;; Delete padding at the bottom of the TDs.
+ (delete-region
+ (point)
+ (progn
+ (skip-chars-backward " \t\n")
+ (end-of-line)
+ (point)))
(goto-char (point-min))
(let ((max 0))
(while (not (eobp))
(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
(list max
(count-lines (point-min) (point-max))
(split-string (buffer-string) "\n")
- (shr-collect-overlays)
+ nil
(car actual-colors))
max)))))
(forward-line 1))
max))
-(defun shr-collect-overlays ()
- (save-excursion
- (goto-char (point-min))
- (let ((overlays nil))
- (while (not (eobp))
- (push (shr-overlays-in-region (point) (line-end-position))
- overlays)
- (forward-line 1))
- (nreverse overlays))))
-
-(defun shr-overlays-in-region (start end)
- (let (result)
- (dolist (overlay (overlays-in start end))
- (push (list (if (> start (overlay-start overlay))
- (- end start)
- (- end (overlay-start overlay)))
- (if (< end (overlay-end overlay))
- 0
- (- end (overlay-end overlay)))
- (overlay-properties overlay))
- result))
- (nreverse result)))
-
(defun shr-pro-rate-columns (columns)
(let ((total-percentage 0)
(widths (make-vector (length columns) 0)))
(shr-count (cdr row) 'th))))))
max))
+;; Emacs less than 24.3
+(unless (fboundp 'add-face-text-property)
+ (defun add-face-text-property (beg end face &optional appendp object)
+ "Combine FACE BEG and END."
+ (let ((b beg))
+ (while (< b end)
+ (let ((oldval (get-text-property b 'face)))
+ (put-text-property
+ b (setq b (next-single-property-change b 'face nil end))
+ 'face (cond ((null oldval)
+ face)
+ ((and (consp oldval)
+ (not (keywordp (car oldval))))
+ (if appendp
+ (nconc oldval (list face))
+ (cons face oldval)))
+ (t
+ (if appendp
+ (list oldval face)
+ (list face oldval))))))))))
+
(provide 'shr)
;; Local Variables: