(require 'subr-x)
(require 'dom)
(require 'seq)
+(require 'svg)
(defgroup shr nil
"Simple HTML Renderer"
(define-key map "w" 'shr-copy-url)
(define-key map "u" 'shr-copy-url)
(define-key map "v" 'shr-browse-url)
- (define-key map "o" 'shr-save-contents)
+ (define-key map "O" 'shr-save-contents)
(define-key map "\r" 'shr-browse-url)
map))
+(defvar shr-image-map
+ (let ((map (copy-keymap shr-map)))
+ (when (boundp 'image-map)
+ (set-keymap-parent map image-map))
+ map))
+
;; Public functions and commands.
(declare-function libxml-parse-html-region "xml.c"
(start end &optional base-url discard-comments))
(create-image data 'svg t :ascent 100))
((eq size 'full)
(ignore-errors
- (shr-rescale-image data content-type)))
+ (shr-rescale-image data content-type
+ (plist-get flags :width)
+ (plist-get flags :height))))
(t
(ignore-errors
- (shr-rescale-image data content-type))))))
+ (shr-rescale-image data content-type
+ (plist-get flags :width)
+ (plist-get flags :height)))))))
(when image
;; When inserting big-ish pictures, put them at the
;; beginning of the line.
image)
(insert (or alt ""))))
-(defun shr-rescale-image (data &optional content-type)
- "Rescale DATA, if too big, to fit the current buffer."
+(defun shr-rescale-image (data content-type width height)
+ "Rescale DATA, if too big, to fit the current buffer.
+WIDTH and HEIGHT are the sizes given in the HTML data, if any."
(if (not (and (fboundp 'imagemagick-types)
(get-buffer-window (current-buffer))))
(create-image data nil t :ascent 100)
- (let ((edges (window-inside-pixel-edges
- (get-buffer-window (current-buffer)))))
- (create-image
- data 'imagemagick t
- :ascent 100
- :max-width (truncate (* shr-max-image-proportion
- (- (nth 2 edges) (nth 0 edges))))
- :max-height (truncate (* shr-max-image-proportion
- (- (nth 3 edges) (nth 1 edges))))
- :format content-type))))
+ (let* ((edges (window-inside-pixel-edges
+ (get-buffer-window (current-buffer))))
+ (max-width (truncate (* shr-max-image-proportion
+ (- (nth 2 edges) (nth 0 edges)))))
+ (max-height (truncate (* shr-max-image-proportion
+ (- (nth 3 edges) (nth 1 edges))))))
+ (when (or (and width
+ (> width max-width))
+ (and height
+ (> height max-height)))
+ (setq width nil
+ height nil))
+ (if (and width height)
+ (create-image
+ data 'imagemagick t
+ :ascent 100
+ :width width
+ :height height
+ :format content-type)
+ (create-image
+ data 'imagemagick t
+ :ascent 100
+ :max-width max-width
+ :max-height max-height
+ :format content-type)))))
;; url-cache-extract autoloads url-cache.
(declare-function url-cache-create-filename "url-cache" (url))
url)))
(if title (format "%s (%s)" iri title) iri))
'follow-link t
- 'mouse-face 'highlight
- 'keymap shr-map)))
+ 'mouse-face 'highlight))
+ ;; Don't overwrite any keymaps that are already in the buffer (i.e.,
+ ;; image keymaps).
+ (while (and start
+ (< start (point)))
+ (let ((next (next-single-property-change start 'keymap nil (point))))
+ (if (get-text-property start 'keymap)
+ (setq start next)
+ (put-text-property start (or next (point)) 'keymap shr-map)))))
(defun shr-encode-url (url)
"Encode URL."
((equal dir "ltr")
(setq bidi-paragraph-direction 'left-to-right))
((equal dir "rtl")
- (setq bidi-paragraph-direction 'right-to-left))))
+ (setq bidi-paragraph-direction 'right-to-left))
+ ((equal dir "auto")
+ (setq bidi-paragraph-direction nil))))
(shr-generic dom))
(defun shr-tag-body (dom)
(shr-ensure-paragraph))
(defun shr-tag-div (dom)
- (shr-ensure-newline)
+ (shr-ensure-paragraph)
(shr-generic dom)
(shr-ensure-newline))
(when (> (current-column) 0)
(insert "\n"))
(let ((alt (dom-attr dom 'alt))
+ (width (shr-string-number (dom-attr dom 'width)))
+ (height (shr-string-number (dom-attr dom 'height)))
(url (shr-expand-url (or url (dom-attr dom 'src)))))
(let ((start (point-marker)))
(when (zerop (length alt))
(string-match "\\`data:" url))
(let ((image (shr-image-from-data (substring url (match-end 0)))))
(if image
- (funcall shr-put-image-function image alt)
+ (funcall shr-put-image-function image alt
+ (list :width width :height height))
(insert alt))))
((and (not shr-inhibit-images)
(string-match "\\`cid:" url))
(if (or (not shr-content-function)
(not (setq image (funcall shr-content-function url))))
(insert alt)
- (funcall shr-put-image-function image alt))))
+ (funcall shr-put-image-function image alt
+ (list :width width :height height)))))
((or shr-inhibit-images
(and shr-blocked-images
(string-match shr-blocked-images url)))
(shr-insert alt))
((and (not shr-ignore-cache)
(url-is-cached (shr-encode-url url)))
- (funcall shr-put-image-function (shr-get-image-data url) alt))
+ (funcall shr-put-image-function (shr-get-image-data url) alt
+ (list :width width :height height)))
(t
- (insert alt " ")
(when (and shr-ignore-cache
(url-is-cached (shr-encode-url url)))
(let ((file (url-cache-create-filename (shr-encode-url url))))
(when (file-exists-p file)
(delete-file file))))
+ (when (image-type-available-p 'svg)
+ (insert-image
+ (shr-make-placeholder-image dom)
+ (or alt "")))
+ (insert " ")
(url-queue-retrieve
(shr-encode-url url) 'shr-image-fetched
- (list (current-buffer) start (set-marker (make-marker) (1- (point))))
+ (list (current-buffer) start (set-marker (make-marker) (1- (point)))
+ (list :width width :height height))
t t)))
(when (zerop shr-table-depth) ;; We are not in a table.
- (put-text-property start (point) 'keymap shr-map)
+ (put-text-property start (point) 'keymap shr-image-map)
(put-text-property start (point) 'shr-alt alt)
(put-text-property start (point) 'image-url url)
(put-text-property start (point) 'image-displayer
(shr-fill-text
(or (dom-attr dom 'title) alt))))))))
+(defun shr-string-number (string)
+ (if (null string)
+ nil
+ (setq string (replace-regexp-in-string "[^0-9]" "" string))
+ (if (zerop (length string))
+ nil
+ (string-to-number string))))
+
+(defun shr-make-placeholder-image (dom)
+ (let* ((edges (and
+ (get-buffer-window (current-buffer))
+ (window-inside-pixel-edges
+ (get-buffer-window (current-buffer)))))
+ (scaling (image-compute-scaling-factor image-scaling-factor))
+ (width (truncate
+ (* (or (shr-string-number (dom-attr dom 'width)) 100)
+ scaling)))
+ (height (truncate
+ (* (or (shr-string-number (dom-attr dom 'height)) 100)
+ scaling)))
+ (max-width
+ (and edges
+ (truncate (* shr-max-image-proportion
+ (- (nth 2 edges) (nth 0 edges))))))
+ (max-height (and edges
+ (truncate (* shr-max-image-proportion
+ (- (nth 3 edges) (nth 1 edges))))))
+ svg image)
+ (when (and max-width
+ (> width max-width))
+ (setq height (truncate (* (/ (float max-width) width) height))
+ width max-width))
+ (when (and max-height
+ (> height max-height))
+ (setq width (truncate (* (/ (float max-height) height) width))
+ height max-height))
+ (setq svg (svg-create width height))
+ (svg-gradient svg "background" 'linear '((0 . "#b0b0b0") (100 . "#808080")))
+ (svg-rectangle svg 0 0 width height :gradient "background"
+ :stroke-width 2 :stroke-color "black")
+ (let ((image (svg-image svg)))
+ (setf (image-property image :ascent) 100)
+ image)))
+
(defun shr-tag-pre (dom)
(let ((shr-folding-mode 'none)
(shr-current-font 'default))
(defun shr-face-background (face)
(and (consp face)
- (let ((background nil))
- (dolist (elem face)
- (when (and (consp elem)
- (eq (car elem) :background))
- (setq background (cadr elem))))
- (and background
- (list :background background)))))
+ (or (and (plist-get face :background)
+ (list :background (plist-get face :background)))
+ (let ((background nil))
+ (dolist (elem face)
+ (when (and (consp elem)
+ (eq (car elem) :background)
+ (not background))
+ (setq background (cadr elem))))
+ (and background
+ (list :background background))))))
(defun shr-expand-alignments (start end)
(while (< (setq start (next-single-property-change