:group 'shr
:type 'regexp)
-(defcustom shr-table-line ?-
- "Character used to draw table line."
+(defcustom shr-table-horizontal-line ?-
+ "Character used to draw horizontal table lines."
+ :group 'shr
+ :type 'character)
+
+(defcustom shr-table-vertical-line ?|
+ "Character used to draw vertical table lines."
:group 'shr
:type 'character)
(defcustom shr-table-corner ?+
- "Character used to draw table corner."
+ "Character used to draw table corners."
:group 'shr
:type 'character)
(defcustom shr-hr-line ?-
- "Character used to draw hr line."
+ "Character used to draw hr lines."
:group 'shr
:type 'character)
(defun shr-browse-image ()
"Browse the image under point."
(interactive)
- (let ((url (get-text-property (point) 'shr-image)))
+ (let ((url (get-text-property (point) 'image-url)))
(if (not url)
(message "No image under point")
(message "Browsing %s..." url)
(defun shr-insert-image ()
"Insert the image under point into the buffer."
(interactive)
- (let ((url (get-text-property (point) 'shr-image)))
+ (let ((url (get-text-property (point) 'image-url)))
(if (not url)
(message "No image under point")
(message "Inserting %s..." url)
(nreverse result)))
(defun shr-descend (dom)
- (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray)))
+ (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))
+ (style (cdr (assq :style (cdr dom))))
+ (start (point)))
+ (when (and style
+ (string-match "color" style))
+ (setq style (shr-parse-style style)))
(if (fboundp function)
(funcall function (cdr dom))
- (shr-generic (cdr dom)))))
+ (shr-generic (cdr dom)))
+ (when (consp style)
+ (shr-insert-color-overlay (cdr (assq 'color style)) start (point)))))
(defun shr-generic (cont)
(dolist (sub cont)
(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))
- (end-of-line))
- (insert " "))
+ (let (found)
+ (while (and (> (current-column) shr-width)
+ (progn
+ (setq found (shr-find-fill-point))
+ (not (eolp))))
+ (when (eq (preceding-char) ? )
+ (delete-char -1))
+ (insert "\n")
+ (unless found
+ (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))
+ (end-of-line))
+ (insert " ")))
(unless (string-match "[ \t\n]\\'" text)
(delete-char -1)))))
(aref (char-category-set (following-char)) ?>)))
(backward-char 1))
(while (and (>= (setq count (1- count)) 0)
- (aref (char-category-set (following-char)) ?>))
+ (aref (char-category-set (following-char)) ?>)
+ (aref fill-find-break-point-function-table
+ (following-char)))
(forward-char 1)))
(when (eq (following-char) ? )
(forward-char 1))
"Browse the URL under point."
(interactive)
(let ((url (get-text-property (point) 'shr-url)))
- (if (not url)
- (message "No link under point")
- (browse-url url))))
+ (cond
+ ((not url)
+ (message "No link under point"))
+ ((string-match "^mailto:" url)
+ (browse-url-mailto url))
+ (t
+ (browse-url url)))))
(defun shr-save-contents (directory)
"Save the contents from URL in a file."
(let ((image (ignore-errors
(shr-rescale-image data))))
(when image
+ ;; When inserting big-ish pictures, put them at the
+ ;; beginning of the line.
+ (when (and (> (current-column) 0)
+ (> (car (image-size image t)) 400))
+ (insert "\n"))
(insert-image image (or alt "*"))))
(insert alt)))
image)))
image)))
+;; url-cache-extract autoloads url-cache.
+(declare-function url-cache-create-filename "url-cache" (url))
+(autoload 'mm-disable-multibyte "mm-util")
+(autoload 'browse-url-mailto "browse-url")
+
(defun shr-get-image-data (url)
"Get image data for URL.
Return a string with image data."
(search-forward "\r\n\r\n" nil t))
(buffer-substring (point) (point-max))))))
+(defun shr-image-displayer (content-function)
+ "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."
+ `(lambda (url start end)
+ (when url
+ (if (string-match "\\`cid:" url)
+ ,(when content-function
+ `(let ((image (funcall ,content-function
+ (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))))))
+ (url-retrieve url 'shr-image-fetched
+ (list (current-buffer) start end)
+ t)))))
+
(defun shr-heading (cont &rest types)
(shr-ensure-paragraph)
(apply #'shr-fontize-cont cont types)
(shr-ensure-paragraph))
+(autoload 'widget-convert-button "wid-edit")
+
(defun shr-urlify (start url)
(widget-convert-button
'url-link start (point)
"Encode URL."
(browse-url-url-encode-chars url "[)$ ]"))
+(autoload 'shr-color-visible "shr-color")
+(autoload 'shr-color->hexadecimal "shr-color")
+(defun shr-color-check (fg &optional bg)
+ "Check that FG is visible on BG."
+ (shr-color-visible (or (shr-color->hexadecimal bg)
+ (frame-parameter nil 'background-color))
+ (shr-color->hexadecimal fg) (not bg)))
+
+(defun shr-insert-color-overlay (color start end)
+ (when color
+ (let ((overlay (make-overlay start end)))
+ (overlay-put overlay 'face (cons 'foreground-color
+ (cadr (shr-color-check color)))))))
+
;;; Tag-specific rendering rules.
(defun shr-tag-p (cont)
(defun shr-parse-style (style)
(when style
+ (save-match-data
+ (when (string-match "\n" style)
+ (setq style (replace-match " " t t style))))
(let ((plist nil))
(dolist (elem (split-string style ";"))
(when elem
(string-match shr-blocked-images url)))
(setq shr-start (point))
(let ((shr-state 'space))
- (if (> (length alt) 8)
- (shr-insert (substring alt 0 8))
+ (if (> (string-width alt) 8)
+ (shr-insert (truncate-string-to-width alt 8))
(shr-insert alt))))
((url-is-cached (shr-encode-url url))
(shr-put-image (shr-get-image-data url) alt))
t))))
(put-text-property start (point) 'keymap shr-map)
(put-text-property start (point) 'shr-alt alt)
- (put-text-property start (point) 'shr-image url)
+ (put-text-property start (point) 'image-url url)
+ (put-text-property start (point) 'image-displayer
+ (shr-image-displayer shr-content-function))
(put-text-property start (point) 'help-echo alt)
(setq shr-state 'image)))))
(shr-ensure-newline)
(insert (make-string shr-width shr-hr-line) "\n"))
+(defun shr-tag-font (cont)
+ (let ((start (point))
+ (color (cdr (assq :color cont))))
+ (shr-generic cont)
+ (shr-insert-color-overlay color start (point))))
+
;;; Table rendering algorithm.
;; Table rendering is the only complicated thing here. We do this by
max)))
(dotimes (i height)
(shr-indent)
- (insert "|\n"))
+ (insert shr-table-vertical-line "\n"))
(dolist (column row)
(goto-char start)
(let ((lines (nth 2 column))
(dolist (line lines)
(setq overlay-line (pop overlay-lines))
(end-of-line)
- (insert line "|")
+ (insert line shr-table-vertical-line)
(dolist (overlay overlay-line)
(let ((o (make-overlay (- (point) (nth 0 overlay) 1)
(- (point) (nth 1 overlay) 1)))
;; possibly.
(dotimes (i (- height (length lines)))
(end-of-line)
- (insert (make-string (string-width (car lines)) ? ) "|")
+ (insert (make-string (string-width (car lines)) ? )
+ shr-table-vertical-line)
(forward-line 1)))))
(shr-insert-table-ruler widths)))
(shr-indent))
(insert shr-table-corner)
(dotimes (i (length widths))
- (insert (make-string (aref widths i) shr-table-line) shr-table-corner))
+ (insert (make-string (aref widths i) shr-table-horizontal-line)
+ shr-table-corner))
(insert "\n"))
(defun shr-table-widths (table suggested-widths)