]> code.delx.au - gnu-emacs/blob - lisp/net/shr.el
; Merge from origin/emacs-25
[gnu-emacs] / lisp / net / shr.el
1 ;;; shr.el --- Simple HTML Renderer
2
3 ;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
4
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: html
7
8 ;; This file is part of GNU Emacs.
9
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
14
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22
23 ;;; Commentary:
24
25 ;; This package takes a HTML parse tree (as provided by
26 ;; libxml-parse-html-region) and renders it in the current buffer. It
27 ;; does not do CSS, JavaScript or anything advanced: It's geared
28 ;; towards rendering typical short snippets of HTML, like what you'd
29 ;; find in HTML email and the like.
30
31 ;;; Code:
32
33 (eval-when-compile (require 'cl))
34 (eval-when-compile (require 'url)) ;For url-filename's setf handler.
35 (require 'browse-url)
36 (require 'subr-x)
37 (require 'dom)
38 (require 'seq)
39 (require 'svg)
40
41 (defgroup shr nil
42 "Simple HTML Renderer"
43 :version "25.1"
44 :group 'web)
45
46 (defcustom shr-max-image-proportion 0.9
47 "How big pictures displayed are in relation to the window they're in.
48 A value of 0.7 means that they are allowed to take up 70% of the
49 width and height of the window. If they are larger than this,
50 and Emacs supports it, then the images will be rescaled down to
51 fit these criteria."
52 :version "24.1"
53 :group 'shr
54 :type 'float)
55
56 (defcustom shr-blocked-images nil
57 "Images that have URLs matching this regexp will be blocked."
58 :version "24.1"
59 :group 'shr
60 :type '(choice (const nil) regexp))
61
62 (defcustom shr-use-fonts t
63 "If non-nil, use proportional fonts for text."
64 :version "25.1"
65 :group 'shr
66 :type 'boolean)
67
68 (defcustom shr-use-colors t
69 "If non-nil, respect color specifications in the HTML."
70 :version "25.2"
71 :group 'shr
72 :type 'boolean)
73
74 (defcustom shr-table-horizontal-line nil
75 "Character used to draw horizontal table lines.
76 If nil, don't draw horizontal table lines."
77 :group 'shr
78 :type '(choice (const nil) character))
79
80 (defcustom shr-table-vertical-line ?\s
81 "Character used to draw vertical table lines."
82 :group 'shr
83 :type 'character)
84
85 (defcustom shr-table-corner ?\s
86 "Character used to draw table corners."
87 :group 'shr
88 :type 'character)
89
90 (defcustom shr-hr-line ?-
91 "Character used to draw hr lines."
92 :group 'shr
93 :type 'character)
94
95 (defcustom shr-width nil
96 "Frame width to use for rendering.
97 May either be an integer specifying a fixed width in characters,
98 or nil, meaning that the full width of the window should be
99 used."
100 :version "25.1"
101 :type '(choice (integer :tag "Fixed width in characters")
102 (const :tag "Use the width of the window" nil))
103 :group 'shr)
104
105 (defcustom shr-bullet "* "
106 "Bullet used for unordered lists.
107 Alternative suggestions are:
108 - \" \"
109 - \" \""
110 :version "24.4"
111 :type 'string
112 :group 'shr)
113
114 (defcustom shr-external-browser 'browse-url-default-browser
115 "Function used to launch an external browser."
116 :version "24.4"
117 :group 'shr
118 :type 'function)
119
120 (defcustom shr-image-animate t
121 "Non nil means that images that can be animated will be."
122 :version "24.4"
123 :group 'shr
124 :type 'boolean)
125
126 (defvar shr-content-function nil
127 "If bound, this should be a function that will return the content.
128 This is used for cid: URLs, and the function is called with the
129 cid: URL as the argument.")
130
131 (defvar shr-put-image-function 'shr-put-image
132 "Function called to put image and alt string.")
133
134 (defface shr-strike-through '((t (:strike-through t)))
135 "Font for <s> elements."
136 :group 'shr)
137
138 (defface shr-link
139 '((t (:inherit link)))
140 "Font for link elements."
141 :group 'shr)
142
143 (defvar shr-inhibit-images nil
144 "If non-nil, inhibit loading images.")
145
146 (defvar shr-external-rendering-functions nil
147 "Alist of tag/function pairs used to alter how shr renders certain tags.
148 For instance, eww uses this to alter rendering of title, forms
149 and other things:
150 ((title . eww-tag-title)
151 (form . eww-tag-form)
152 ...)")
153
154 ;;; Internal variables.
155
156 (defvar shr-folding-mode nil)
157 (defvar shr-start nil)
158 (defvar shr-indentation 0)
159 (defvar shr-internal-width nil)
160 (defvar shr-list-mode nil)
161 (defvar shr-content-cache nil)
162 (defvar shr-kinsoku-shorten nil)
163 (defvar shr-table-depth 0)
164 (defvar shr-stylesheet nil)
165 (defvar shr-base nil)
166 (defvar shr-depth 0)
167 (defvar shr-warning nil)
168 (defvar shr-ignore-cache nil)
169 (defvar shr-target-id nil)
170 (defvar shr-table-separator-length 1)
171 (defvar shr-table-separator-pixel-width 0)
172 (defvar shr-table-id nil)
173 (defvar shr-current-font nil)
174 (defvar shr-internal-bullet nil)
175
176 (defvar shr-map
177 (let ((map (make-sparse-keymap)))
178 (define-key map "a" 'shr-show-alt-text)
179 (define-key map "i" 'shr-browse-image)
180 (define-key map "z" 'shr-zoom-image)
181 (define-key map [?\t] 'shr-next-link)
182 (define-key map [?\M-\t] 'shr-previous-link)
183 (define-key map [follow-link] 'mouse-face)
184 (define-key map [mouse-2] 'shr-browse-url)
185 (define-key map "I" 'shr-insert-image)
186 (define-key map "w" 'shr-copy-url)
187 (define-key map "u" 'shr-copy-url)
188 (define-key map "v" 'shr-browse-url)
189 (define-key map "O" 'shr-save-contents)
190 (define-key map "\r" 'shr-browse-url)
191 map))
192
193 (defvar shr-image-map
194 (let ((map (copy-keymap shr-map)))
195 (when (boundp 'image-map)
196 (set-keymap-parent map image-map))
197 map))
198
199 ;; Public functions and commands.
200 (declare-function libxml-parse-html-region "xml.c"
201 (start end &optional base-url discard-comments))
202
203 (defun shr-render-buffer (buffer)
204 "Display the HTML rendering of the current buffer."
205 (interactive (list (current-buffer)))
206 (or (fboundp 'libxml-parse-html-region)
207 (error "This function requires Emacs to be compiled with libxml2"))
208 (pop-to-buffer "*html*")
209 (erase-buffer)
210 (shr-insert-document
211 (with-current-buffer buffer
212 (libxml-parse-html-region (point-min) (point-max))))
213 (goto-char (point-min)))
214
215 ;;;###autoload
216 (defun shr-render-region (begin end &optional buffer)
217 "Display the HTML rendering of the region between BEGIN and END."
218 (interactive "r")
219 (unless (fboundp 'libxml-parse-html-region)
220 (error "This function requires Emacs to be compiled with libxml2"))
221 (with-current-buffer (or buffer (current-buffer))
222 (let ((dom (libxml-parse-html-region begin end)))
223 (delete-region begin end)
224 (goto-char begin)
225 (shr-insert-document dom))))
226
227 (defun shr--have-one-fringe-p ()
228 "Return non-nil if we know at least one of the fringes has non-zero width."
229 (and (fboundp 'fringe-columns)
230 (or (not (zerop (fringe-columns 'right)))
231 (not (zerop (fringe-columns 'left))))))
232
233 ;;;###autoload
234 (defun shr-insert-document (dom)
235 "Render the parsed document DOM into the current buffer.
236 DOM should be a parse tree as generated by
237 `libxml-parse-html-region' or similar."
238 (setq shr-content-cache nil)
239 (let ((start (point))
240 (shr-start nil)
241 (shr-base nil)
242 (shr-depth 0)
243 (shr-table-id 0)
244 (shr-warning nil)
245 (shr-table-separator-pixel-width (shr-string-pixel-width "-"))
246 (shr-internal-bullet (cons shr-bullet
247 (shr-string-pixel-width shr-bullet)))
248 (shr-internal-width (or (and shr-width
249 (if (not shr-use-fonts)
250 shr-width
251 (* shr-width (frame-char-width))))
252 ;; We need to adjust the available
253 ;; width for when the user disables
254 ;; the fringes, which will cause the
255 ;; display engine usurp one column for
256 ;; the continuation glyph.
257 (if (not shr-use-fonts)
258 (- (window-body-width) 1
259 (if (and (null shr-width)
260 (not (shr--have-one-fringe-p)))
261 0
262 1))
263 (- (window-body-width nil t)
264 (* 2 (frame-char-width))
265 (if (and (null shr-width)
266 (not (shr--have-one-fringe-p)))
267 (* (frame-char-width) 2)
268 0)))))
269 bidi-display-reordering)
270 ;; If the window was hscrolled for some reason, shr-fill-lines
271 ;; below will misbehave, because it silently assumes that it
272 ;; starts with a non-hscrolled window (vertical-motion will move
273 ;; to a wrong place otherwise).
274 (set-window-hscroll nil 0)
275 (shr-descend dom)
276 (shr-fill-lines start (point))
277 (shr--remove-blank-lines-at-the-end start (point))
278 (when shr-warning
279 (message "%s" shr-warning))))
280
281 (defun shr--remove-blank-lines-at-the-end (start end)
282 (save-restriction
283 (save-excursion
284 (narrow-to-region start end)
285 (goto-char end)
286 (when (and (re-search-backward "[^ \n]" nil t)
287 (not (eobp)))
288 (forward-line 1)
289 (delete-region (point) (point-max))))))
290
291 (defun shr-copy-url (&optional image-url)
292 "Copy the URL under point to the kill ring.
293 If IMAGE-URL (the prefix) is non-nil, or there is no link under
294 point, but there is an image under point then copy the URL of the
295 image under point instead.
296 If called twice, then try to fetch the URL and see whether it
297 redirects somewhere else."
298 (interactive "P")
299 (let ((url (or (get-text-property (point) 'shr-url)
300 (get-text-property (point) 'image-url))))
301 (cond
302 ((not url)
303 (message "No URL under point"))
304 ;; Resolve redirected URLs.
305 ((equal url (car kill-ring))
306 (url-retrieve
307 url
308 (lambda (a)
309 (when (and (consp a)
310 (eq (car a) :redirect))
311 (with-temp-buffer
312 (insert (cadr a))
313 (goto-char (point-min))
314 ;; Remove common tracking junk from the URL.
315 (when (re-search-forward ".utm_.*" nil t)
316 (replace-match "" t t))
317 (message "Copied %s" (buffer-string))
318 (copy-region-as-kill (point-min) (point-max)))))
319 nil t))
320 ;; Copy the URL to the kill ring.
321 (t
322 (with-temp-buffer
323 (insert (url-encode-url url))
324 (copy-region-as-kill (point-min) (point-max))
325 (message "Copied %s" (buffer-string)))))))
326
327 (defun shr-next-link ()
328 "Skip to the next link."
329 (interactive)
330 (let ((current (get-text-property (point) 'shr-url))
331 (start (point))
332 skip)
333 (while (and (not (eobp))
334 (equal (get-text-property (point) 'shr-url) current))
335 (forward-char 1))
336 (cond
337 ((and (not (eobp))
338 (get-text-property (point) 'shr-url))
339 ;; The next link is adjacent.
340 (message "%s" (get-text-property (point) 'help-echo)))
341 ((or (eobp)
342 (not (setq skip (text-property-not-all (point) (point-max)
343 'shr-url nil))))
344 (goto-char start)
345 (message "No next link"))
346 (t
347 (goto-char skip)
348 (message "%s" (get-text-property (point) 'help-echo))))))
349
350 (defun shr-previous-link ()
351 "Skip to the previous link."
352 (interactive)
353 (let ((start (point))
354 (found nil))
355 ;; Skip past the current link.
356 (while (and (not (bobp))
357 (get-text-property (point) 'help-echo))
358 (forward-char -1))
359 ;; Find the previous link.
360 (while (and (not (bobp))
361 (not (setq found (get-text-property (point) 'help-echo))))
362 (forward-char -1))
363 (if (not found)
364 (progn
365 (message "No previous link")
366 (goto-char start))
367 ;; Put point at the start of the link.
368 (while (and (not (bobp))
369 (get-text-property (point) 'help-echo))
370 (forward-char -1))
371 (forward-char 1)
372 (message "%s" (get-text-property (point) 'help-echo)))))
373
374 (defun shr-show-alt-text ()
375 "Show the ALT text of the image under point."
376 (interactive)
377 (let ((text (get-text-property (point) 'shr-alt)))
378 (if (not text)
379 (message "No image under point")
380 (message "%s" (shr-fill-text text)))))
381
382 (defun shr-browse-image (&optional copy-url)
383 "Browse the image under point.
384 If COPY-URL (the prefix if called interactively) is non-nil, copy
385 the URL of the image to the kill buffer instead."
386 (interactive "P")
387 (let ((url (get-text-property (point) 'image-url)))
388 (cond
389 ((not url)
390 (message "No image under point"))
391 (copy-url
392 (with-temp-buffer
393 (insert url)
394 (copy-region-as-kill (point-min) (point-max))
395 (message "Copied %s" url)))
396 (t
397 (message "Browsing %s..." url)
398 (browse-url url)))))
399
400 (defun shr-insert-image ()
401 "Insert the image under point into the buffer."
402 (interactive)
403 (let ((url (get-text-property (point) 'image-url)))
404 (if (not url)
405 (message "No image under point")
406 (message "Inserting %s..." url)
407 (url-retrieve url 'shr-image-fetched
408 (list (current-buffer) (1- (point)) (point-marker))
409 t t))))
410
411 (defun shr-zoom-image ()
412 "Toggle the image size.
413 The size will be rotated between the default size, the original
414 size, and full-buffer size."
415 (interactive)
416 (let ((url (get-text-property (point) 'image-url))
417 (size (get-text-property (point) 'image-size))
418 (buffer-read-only nil))
419 (if (not url)
420 (message "No image under point")
421 ;; Delete the old picture.
422 (while (get-text-property (point) 'image-url)
423 (forward-char -1))
424 (forward-char 1)
425 (let ((start (point)))
426 (while (get-text-property (point) 'image-url)
427 (forward-char 1))
428 (forward-char -1)
429 (put-text-property start (point) 'display nil)
430 (when (> (- (point) start) 2)
431 (delete-region start (1- (point)))))
432 (message "Inserting %s..." url)
433 (url-retrieve url 'shr-image-fetched
434 (list (current-buffer) (1- (point)) (point-marker)
435 (list (cons 'size
436 (cond ((or (eq size 'default)
437 (null size))
438 'original)
439 ((eq size 'original)
440 'full)
441 ((eq size 'full)
442 'default)))))
443 t))))
444
445 ;;; Utility functions.
446
447 (defsubst shr-generic (dom)
448 (dolist (sub (dom-children dom))
449 (if (stringp sub)
450 (shr-insert sub)
451 (shr-descend sub))))
452
453 (defun shr-descend (dom)
454 (let ((function
455 (intern (concat "shr-tag-" (symbol-name (dom-tag dom))) obarray))
456 ;; Allow other packages to override (or provide) rendering
457 ;; of elements.
458 (external (cdr (assq (dom-tag dom) shr-external-rendering-functions)))
459 (style (dom-attr dom 'style))
460 (shr-stylesheet shr-stylesheet)
461 (shr-depth (1+ shr-depth))
462 (start (point)))
463 ;; shr uses many frames per nested node.
464 (if (> shr-depth (/ max-specpdl-size 15))
465 (setq shr-warning "Too deeply nested to render properly; consider increasing `max-specpdl-size'")
466 (when style
467 (if (string-match "color\\|display\\|border-collapse" style)
468 (setq shr-stylesheet (nconc (shr-parse-style style)
469 shr-stylesheet))
470 (setq style nil)))
471 ;; If we have a display:none, then just ignore this part of the DOM.
472 (unless (equal (cdr (assq 'display shr-stylesheet)) "none")
473 (cond (external
474 (funcall external dom))
475 ((fboundp function)
476 (funcall function dom))
477 (t
478 (shr-generic dom)))
479 (when (and shr-target-id
480 (equal (dom-attr dom 'id) shr-target-id))
481 ;; If the element was empty, we don't have anything to put the
482 ;; anchor on. So just insert a dummy character.
483 (when (= start (point))
484 (insert "*"))
485 (put-text-property start (1+ start) 'shr-target-id shr-target-id))
486 ;; If style is set, then this node has set the color.
487 (when style
488 (shr-colorize-region
489 start (point)
490 (cdr (assq 'color shr-stylesheet))
491 (cdr (assq 'background-color shr-stylesheet))))))))
492
493 (defun shr-fill-text (text)
494 (if (zerop (length text))
495 text
496 (with-temp-buffer
497 (let ((shr-indentation 0)
498 (shr-start nil)
499 (shr-internal-width (- (window-body-width nil t)
500 (* 2 (frame-char-width))
501 ;; Adjust the window width for when
502 ;; the user disables the fringes,
503 ;; which causes the display engine
504 ;; to usurp one column for the
505 ;; continuation glyph.
506 (if (and (null shr-width)
507 (not (shr--have-one-fringe-p)))
508 (* (frame-char-width) 2)
509 0))))
510 (shr-insert text)
511 (buffer-string)))))
512
513 (define-inline shr-char-breakable-p (char)
514 "Return non-nil if a line can be broken before and after CHAR."
515 (inline-quote (aref fill-find-break-point-function-table ,char)))
516 (define-inline shr-char-nospace-p (char)
517 "Return non-nil if no space is required before and after CHAR."
518 (inline-quote (aref fill-nospace-between-words-table ,char)))
519
520 ;; KINSOKU is a Japanese word meaning a rule that should not be violated.
521 ;; In Emacs, it is a term used for characters, e.g. punctuation marks,
522 ;; parentheses, and so on, that should not be placed in the beginning
523 ;; of a line or the end of a line.
524 (define-inline shr-char-kinsoku-bol-p (char)
525 "Return non-nil if a line ought not to begin with CHAR."
526 (inline-letevals (char)
527 (inline-quote (and (not (eq ,char ?'))
528 (aref (char-category-set ,char) ?>)))))
529 (define-inline shr-char-kinsoku-eol-p (char)
530 "Return non-nil if a line ought not to end with CHAR."
531 (inline-quote (aref (char-category-set ,char) ?<)))
532 (unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
533 (load "kinsoku" nil t))
534
535 (defun shr-pixel-column ()
536 (if (not shr-use-fonts)
537 (current-column)
538 (if (not (get-buffer-window (current-buffer)))
539 (save-window-excursion
540 (set-window-buffer nil (current-buffer))
541 (car (window-text-pixel-size nil (line-beginning-position) (point))))
542 (car (window-text-pixel-size nil (line-beginning-position) (point))))))
543
544 (defun shr-pixel-region ()
545 (- (shr-pixel-column)
546 (save-excursion
547 (goto-char (mark))
548 (shr-pixel-column))))
549
550 (defun shr-string-pixel-width (string)
551 (if (not shr-use-fonts)
552 (length string)
553 (with-temp-buffer
554 (insert string)
555 (shr-pixel-column))))
556
557 (defsubst shr--translate-insertion-chars ()
558 ;; Remove soft hyphens.
559 (goto-char (point-min))
560 (while (search-forward "­" nil t)
561 (replace-match "" t t))
562 ;; Translate non-breaking spaces into real spaces.
563 (goto-char (point-min))
564 (while (search-forward " " nil t)
565 (replace-match " " t t)))
566
567 (defun shr-insert (text)
568 (when (and (not (bolp))
569 (get-text-property (1- (point)) 'image-url))
570 (insert "\n"))
571 (cond
572 ((eq shr-folding-mode 'none)
573 (let ((start (point)))
574 (insert text)
575 (save-restriction
576 (narrow-to-region start (point))
577 (shr--translate-insertion-chars)
578 (goto-char (point-max)))))
579 (t
580 (let ((font-start (point)))
581 (when (and (string-match "\\`[ \t\n\r]" text)
582 (not (bolp))
583 (not (eq (char-after (1- (point))) ? )))
584 (insert " "))
585 (let ((start (point))
586 (bolp (bolp)))
587 (insert text)
588 (save-restriction
589 (narrow-to-region start (point))
590 (goto-char start)
591 (when (looking-at "[ \t\n\r]+")
592 (replace-match "" t t))
593 (while (re-search-forward "[ \t\n\r]+" nil t)
594 (replace-match " " t t))
595 (shr--translate-insertion-chars)
596 (goto-char (point-max)))
597 ;; We may have removed everything we inserted if if was just
598 ;; spaces.
599 (unless (= font-start (point))
600 ;; Mark all lines that should possibly be folded afterwards.
601 (when bolp
602 (shr-mark-fill start))
603 (when shr-use-fonts
604 (put-text-property font-start (point)
605 'face
606 (or shr-current-font 'variable-pitch)))))))))
607
608 (defun shr-fill-lines (start end)
609 (if (<= shr-internal-width 0)
610 nil
611 (save-restriction
612 (narrow-to-region start end)
613 (goto-char start)
614 (when (get-text-property (point) 'shr-indentation)
615 (shr-fill-line))
616 (while (setq start (next-single-property-change start 'shr-indentation))
617 (goto-char start)
618 (when (bolp)
619 (shr-fill-line)))
620 (goto-char (point-max)))))
621
622 (defun shr-vertical-motion (column)
623 (if (not shr-use-fonts)
624 (move-to-column column)
625 (unless (eolp)
626 (forward-char 1))
627 (vertical-motion (cons (/ column (frame-char-width)) 0))
628 (unless (eolp)
629 (forward-char 1))))
630
631 (defun shr-fill-line ()
632 (let ((shr-indentation (get-text-property (point) 'shr-indentation))
633 (continuation (get-text-property
634 (point) 'shr-continuation-indentation))
635 start)
636 (put-text-property (point) (1+ (point)) 'shr-indentation nil)
637 (let ((face (get-text-property (point) 'face))
638 (background-start (point)))
639 (shr-indent)
640 (when face
641 (put-text-property background-start (point) 'face
642 `,(shr-face-background face))))
643 (setq start (point))
644 (setq shr-indentation (or continuation shr-indentation))
645 (shr-vertical-motion shr-internal-width)
646 (when (looking-at " $")
647 (delete-region (point) (line-end-position)))
648 (while (not (eolp))
649 ;; We have to do some folding. First find the first
650 ;; previous point suitable for folding.
651 (if (or (not (shr-find-fill-point (line-beginning-position)))
652 (= (point) start))
653 ;; We had unbreakable text (for this width), so just go to
654 ;; the first space and carry on.
655 (progn
656 (beginning-of-line)
657 (skip-chars-forward " ")
658 (search-forward " " (line-end-position) 'move)))
659 ;; Success; continue.
660 (when (= (preceding-char) ?\s)
661 (delete-char -1))
662 (let ((face (get-text-property (point) 'face))
663 (background-start (point)))
664 (insert "\n")
665 (shr-indent)
666 (when face
667 (put-text-property background-start (point) 'face
668 `,(shr-face-background face))))
669 (setq start (point))
670 (shr-vertical-motion shr-internal-width)
671 (when (looking-at " $")
672 (delete-region (point) (line-end-position))))))
673
674 (defun shr-find-fill-point (start)
675 (let ((bp (point))
676 (end (point))
677 failed)
678 (while (not (or (setq failed (<= (point) start))
679 (eq (preceding-char) ? )
680 (eq (following-char) ? )
681 (shr-char-breakable-p (preceding-char))
682 (shr-char-breakable-p (following-char))
683 (and (shr-char-kinsoku-bol-p (preceding-char))
684 (shr-char-breakable-p (following-char))
685 (not (shr-char-kinsoku-bol-p (following-char))))
686 (shr-char-kinsoku-eol-p (following-char))
687 (bolp)))
688 (backward-char 1))
689 (if failed
690 ;; There's no breakable point, so we give it up.
691 (let (found)
692 (goto-char bp)
693 ;; Don't overflow the window edge, even if
694 ;; shr-kinsoku-shorten is nil.
695 (unless (or shr-kinsoku-shorten (null shr-width))
696 (while (setq found (re-search-forward
697 "\\(\\c>\\)\\| \\|\\c<\\|\\c|"
698 (line-end-position) 'move)))
699 (if (and found
700 (not (match-beginning 1)))
701 (goto-char (match-beginning 0)))))
702 (or
703 (eolp)
704 ;; Don't put kinsoku-bol characters at the beginning of a line,
705 ;; or kinsoku-eol characters at the end of a line.
706 (cond
707 ;; Don't overflow the window edge, even if shr-kinsoku-shorten
708 ;; is nil.
709 ((or shr-kinsoku-shorten (null shr-width))
710 (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
711 (or (shr-char-kinsoku-eol-p (preceding-char))
712 (shr-char-kinsoku-bol-p (following-char))))
713 (backward-char 1))
714 (when (setq failed (<= (point) start))
715 ;; There's no breakable point that doesn't violate kinsoku,
716 ;; so we look for the second best position.
717 (while (and (progn
718 (forward-char 1)
719 (<= (point) end))
720 (progn
721 (setq bp (point))
722 (shr-char-kinsoku-eol-p (following-char)))))
723 (goto-char bp)))
724 ((shr-char-kinsoku-eol-p (preceding-char))
725 ;; Find backward the point where kinsoku-eol characters begin.
726 (let ((count 4))
727 (while
728 (progn
729 (backward-char 1)
730 (and (> (setq count (1- count)) 0)
731 (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
732 (or (shr-char-kinsoku-eol-p (preceding-char))
733 (shr-char-kinsoku-bol-p (following-char)))))))
734 (when (setq failed (<= (point) start))
735 ;; There's no breakable point that doesn't violate kinsoku,
736 ;; so we go to the second best position.
737 (if (looking-at "\\(\\c<+\\)\\c<")
738 (goto-char (match-end 1))
739 (forward-char 1))))
740 ((shr-char-kinsoku-bol-p (following-char))
741 ;; Find forward the point where kinsoku-bol characters end.
742 (let ((count 4))
743 (while (progn
744 (forward-char 1)
745 (and (>= (setq count (1- count)) 0)
746 (shr-char-kinsoku-bol-p (following-char))
747 (shr-char-breakable-p (following-char))))))))
748 (when (eq (following-char) ? )
749 (forward-char 1))))
750 (not failed)))
751
752 (defun shr-parse-base (url)
753 ;; Always chop off anchors.
754 (when (string-match "#.*" url)
755 (setq url (substring url 0 (match-beginning 0))))
756 ;; NB: <base href="" > URI may itself be relative to the document s URI
757 (setq url (shr-expand-url url))
758 (let* ((parsed (url-generic-parse-url url))
759 (local (url-filename parsed)))
760 (setf (url-filename parsed) "")
761 ;; Chop off the bit after the last slash.
762 (when (string-match "\\`\\(.*/\\)[^/]+\\'" local)
763 (setq local (match-string 1 local)))
764 ;; Always make the local bit end with a slash.
765 (when (and (not (zerop (length local)))
766 (not (eq (aref local (1- (length local))) ?/)))
767 (setq local (concat local "/")))
768 (list (url-recreate-url parsed)
769 local
770 (url-type parsed)
771 url)))
772
773 (autoload 'url-expand-file-name "url-expand")
774
775 ;; FIXME This needs some tests writing.
776 ;; Does it even need to exist, given that url-expand-file-name does?
777 (defun shr-expand-url (url &optional base)
778 (setq base
779 (if base
780 ;; shr-parse-base should never call this with non-nil base!
781 (shr-parse-base base)
782 ;; Bound by the parser.
783 shr-base))
784 (when (zerop (length url))
785 (setq url nil))
786 ;; Strip leading whitespace
787 (and url (string-match "\\`\\s-+" url)
788 (setq url (substring url (match-end 0))))
789 (cond ((or (not url)
790 (not base)
791 (string-match "\\`[a-z]*:" url))
792 ;; Absolute or empty URI
793 (or url (nth 3 base)))
794 ((eq (aref url 0) ?/)
795 (if (and (> (length url) 1)
796 (eq (aref url 1) ?/))
797 ;; //host...; just use the protocol
798 (concat (nth 2 base) ":" url)
799 ;; Just use the host name part.
800 (concat (car base) url)))
801 ((eq (aref url 0) ?#)
802 ;; A link to an anchor.
803 (concat (nth 3 base) url))
804 (t
805 ;; Totally relative.
806 (url-expand-file-name url (concat (car base) (cadr base))))))
807
808 (defun shr-ensure-newline ()
809 (unless (bobp)
810 (let ((prefix (get-text-property (line-beginning-position)
811 'shr-prefix-length)))
812 (unless (or (zerop (current-column))
813 (and prefix
814 (= prefix (- (point) (line-beginning-position)))))
815 (insert "\n")))))
816
817 (defun shr-ensure-paragraph ()
818 (unless (bobp)
819 (let ((prefix (get-text-property (line-beginning-position)
820 'shr-prefix-length)))
821 (cond
822 ((and (bolp)
823 (save-excursion
824 (forward-line -1)
825 (looking-at " *$")))
826 ;; We're already at a new paragraph; do nothing.
827 )
828 ((and prefix
829 (= prefix (- (point) (line-beginning-position))))
830 ;; Do nothing; we're at the start of a <li>.
831 )
832 ((save-excursion
833 (beginning-of-line)
834 ;; If the current line is totally blank, and doesn't even
835 ;; have any face properties set, then delete the blank
836 ;; space.
837 (and (looking-at " *$")
838 (not (get-text-property (point) 'face))
839 (not (= (next-single-property-change (point) 'face nil
840 (line-end-position))
841 (line-end-position)))))
842 (delete-region (match-beginning 0) (match-end 0)))
843 ;; We have a single blank line.
844 ((and (eolp) (bolp))
845 (insert "\n"))
846 ;; Insert new paragraph.
847 (t
848 (insert "\n\n"))))))
849
850 (defun shr-indent ()
851 (when (> shr-indentation 0)
852 (insert
853 (if (not shr-use-fonts)
854 (make-string shr-indentation ?\s)
855 (propertize " "
856 'display
857 `(space :width (,shr-indentation)))))))
858
859 (defun shr-fontize-dom (dom &rest types)
860 (let ((start (point)))
861 (shr-generic dom)
862 (dolist (type types)
863 (shr-add-font start (point) type))))
864
865 ;; Add face to the region, but avoid putting the font properties on
866 ;; blank text at the start of the line, and the newline at the end, to
867 ;; avoid ugliness.
868 (defun shr-add-font (start end type)
869 (save-excursion
870 (goto-char start)
871 (while (< (point) end)
872 (when (bolp)
873 (skip-chars-forward " "))
874 (add-face-text-property (point) (min (line-end-position) end) type t)
875 (if (< (line-end-position) end)
876 (forward-line 1)
877 (goto-char end)))))
878
879 (defun shr-mouse-browse-url (ev)
880 "Browse the URL under the mouse cursor."
881 (interactive "e")
882 (mouse-set-point ev)
883 (shr-browse-url))
884
885 (defun shr-browse-url (&optional external mouse-event)
886 "Browse the URL under point.
887 If EXTERNAL, browse the URL using `shr-external-browser'."
888 (interactive (list current-prefix-arg last-nonmenu-event))
889 (mouse-set-point mouse-event)
890 (let ((url (get-text-property (point) 'shr-url)))
891 (cond
892 ((not url)
893 (message "No link under point"))
894 ((string-match "^mailto:" url)
895 (browse-url-mail url))
896 (t
897 (if external
898 (funcall shr-external-browser url)
899 (browse-url url))))))
900
901 (defun shr-save-contents (directory)
902 "Save the contents from URL in a file."
903 (interactive "DSave contents of URL to directory: ")
904 (let ((url (get-text-property (point) 'shr-url)))
905 (if (not url)
906 (message "No link under point")
907 (url-retrieve (shr-encode-url url)
908 'shr-store-contents (list url directory)
909 nil t))))
910
911 (defun shr-store-contents (status url directory)
912 (unless (plist-get status :error)
913 (when (or (search-forward "\n\n" nil t)
914 (search-forward "\r\n\r\n" nil t))
915 (write-region (point) (point-max)
916 (expand-file-name (file-name-nondirectory url)
917 directory)))))
918
919 (defun shr-image-fetched (status buffer start end &optional flags)
920 (let ((image-buffer (current-buffer)))
921 (when (and (buffer-name buffer)
922 (not (plist-get status :error)))
923 (url-store-in-cache image-buffer)
924 (when (or (search-forward "\n\n" nil t)
925 (search-forward "\r\n\r\n" nil t))
926 (let ((data (shr-parse-image-data)))
927 (with-current-buffer buffer
928 (save-excursion
929 (let ((alt (buffer-substring start end))
930 (properties (text-properties-at start))
931 (inhibit-read-only t))
932 (delete-region start end)
933 (goto-char start)
934 (funcall shr-put-image-function data alt flags)
935 (while properties
936 (let ((type (pop properties))
937 (value (pop properties)))
938 (unless (memq type '(display image-size))
939 (put-text-property start (point) type value))))))))))
940 (kill-buffer image-buffer)))
941
942 (defun shr-image-from-data (data)
943 "Return an image from the data: URI content DATA."
944 (when (string-match
945 "\\(\\([^/;,]+\\(/[^;,]+\\)?\\)\\(;[^;,]+\\)*\\)?,\\(.*\\)"
946 data)
947 (let ((param (match-string 4 data))
948 (payload (url-unhex-string (match-string 5 data))))
949 (when (string-match "^.*\\(;[ \t]*base64\\)$" param)
950 (setq payload (ignore-errors
951 (base64-decode-string payload))))
952 payload)))
953
954 ;; Behind display-graphic-p test.
955 (declare-function image-size "image.c" (spec &optional pixels frame))
956 (declare-function image-animate "image" (image &optional index limit))
957
958 (defun shr-put-image (spec alt &optional flags)
959 "Insert image SPEC with a string ALT. Return image.
960 SPEC is either an image data blob, or a list where the first
961 element is the data blob and the second element is the content-type."
962 (if (display-graphic-p)
963 (let* ((size (cdr (assq 'size flags)))
964 (data (if (consp spec)
965 (car spec)
966 spec))
967 (content-type (and (consp spec)
968 (cadr spec)))
969 (start (point))
970 (image (cond
971 ((eq size 'original)
972 (create-image data nil t :ascent 100
973 :format content-type))
974 ((eq content-type 'image/svg+xml)
975 (create-image data 'svg t :ascent 100))
976 ((eq size 'full)
977 (ignore-errors
978 (shr-rescale-image data content-type
979 (plist-get flags :width)
980 (plist-get flags :height))))
981 (t
982 (ignore-errors
983 (shr-rescale-image data content-type
984 (plist-get flags :width)
985 (plist-get flags :height)))))))
986 (when image
987 ;; When inserting big-ish pictures, put them at the
988 ;; beginning of the line.
989 (when (and (> (current-column) 0)
990 (> (car (image-size image t)) 400))
991 (insert "\n"))
992 (if (eq size 'original)
993 (insert-sliced-image image (or alt "*") nil 20 1)
994 (insert-image image (or alt "*")))
995 (put-text-property start (point) 'image-size size)
996 (when (and shr-image-animate
997 (cond ((fboundp 'image-multi-frame-p)
998 ;; Only animate multi-frame things that specify a
999 ;; delay; eg animated gifs as opposed to
1000 ;; multi-page tiffs. FIXME?
1001 (cdr (image-multi-frame-p image)))
1002 ((fboundp 'image-animated-p)
1003 (image-animated-p image))))
1004 (image-animate image nil 60)))
1005 image)
1006 (insert (or alt ""))))
1007
1008 (defun shr-rescale-image (data content-type width height)
1009 "Rescale DATA, if too big, to fit the current buffer.
1010 WIDTH and HEIGHT are the sizes given in the HTML data, if any."
1011 (if (not (and (fboundp 'imagemagick-types)
1012 (get-buffer-window (current-buffer))))
1013 (create-image data nil t :ascent 100)
1014 (let* ((edges (window-inside-pixel-edges
1015 (get-buffer-window (current-buffer))))
1016 (max-width (truncate (* shr-max-image-proportion
1017 (- (nth 2 edges) (nth 0 edges)))))
1018 (max-height (truncate (* shr-max-image-proportion
1019 (- (nth 3 edges) (nth 1 edges))))))
1020 (when (or (and width
1021 (> width max-width))
1022 (and height
1023 (> height max-height)))
1024 (setq width nil
1025 height nil))
1026 (if (and width height)
1027 (create-image
1028 data 'imagemagick t
1029 :ascent 100
1030 :width width
1031 :height height
1032 :format content-type)
1033 (create-image
1034 data 'imagemagick t
1035 :ascent 100
1036 :max-width max-width
1037 :max-height max-height
1038 :format content-type)))))
1039
1040 ;; url-cache-extract autoloads url-cache.
1041 (declare-function url-cache-create-filename "url-cache" (url))
1042 (autoload 'mm-disable-multibyte "mm-util")
1043 (autoload 'browse-url-mail "browse-url")
1044
1045 (defun shr-get-image-data (url)
1046 "Get image data for URL.
1047 Return a string with image data."
1048 (with-temp-buffer
1049 (mm-disable-multibyte)
1050 (when (ignore-errors
1051 (url-cache-extract (url-cache-create-filename (shr-encode-url url)))
1052 t)
1053 (when (or (search-forward "\n\n" nil t)
1054 (search-forward "\r\n\r\n" nil t))
1055 (shr-parse-image-data)))))
1056
1057 (declare-function libxml-parse-xml-region "xml.c"
1058 (start end &optional base-url discard-comments))
1059
1060 (defun shr-parse-image-data ()
1061 (let ((data (buffer-substring (point) (point-max)))
1062 (content-type
1063 (save-excursion
1064 (save-restriction
1065 (narrow-to-region (point-min) (point))
1066 (let ((content-type (mail-fetch-field "content-type")))
1067 (and content-type
1068 ;; Remove any comments in the type string.
1069 (intern (replace-regexp-in-string ";.*" "" content-type)
1070 obarray)))))))
1071 ;; SVG images may contain references to further images that we may
1072 ;; want to block. So special-case these by parsing the XML data
1073 ;; and remove the blocked bits.
1074 (when (eq content-type 'image/svg+xml)
1075 (setq data
1076 (shr-dom-to-xml
1077 (libxml-parse-xml-region (point) (point-max)))))
1078 (list data content-type)))
1079
1080 (defun shr-image-displayer (content-function)
1081 "Return a function to display an image.
1082 CONTENT-FUNCTION is a function to retrieve an image for a cid url that
1083 is an argument. The function to be returned takes three arguments URL,
1084 START, and END. Note that START and END should be markers."
1085 `(lambda (url start end)
1086 (when url
1087 (if (string-match "\\`cid:" url)
1088 ,(when content-function
1089 `(let ((image (funcall ,content-function
1090 (substring url (match-end 0)))))
1091 (when image
1092 (goto-char start)
1093 (funcall shr-put-image-function
1094 image (buffer-substring start end))
1095 (delete-region (point) end))))
1096 (url-retrieve url 'shr-image-fetched
1097 (list (current-buffer) start end)
1098 t t)))))
1099
1100 (defun shr-heading (dom &rest types)
1101 (shr-ensure-paragraph)
1102 (apply #'shr-fontize-dom dom types)
1103 (shr-ensure-paragraph))
1104
1105 (defun shr-urlify (start url &optional title)
1106 (shr-add-font start (point) 'shr-link)
1107 (add-text-properties
1108 start (point)
1109 (list 'shr-url url
1110 'help-echo (let ((iri (or (ignore-errors
1111 (decode-coding-string
1112 (url-unhex-string url)
1113 'utf-8 t))
1114 url)))
1115 (if title (format "%s (%s)" iri title) iri))
1116 'follow-link t
1117 'mouse-face 'highlight))
1118 ;; Don't overwrite any keymaps that are already in the buffer (i.e.,
1119 ;; image keymaps).
1120 (while (and start
1121 (< start (point)))
1122 (let ((next (next-single-property-change start 'keymap nil (point))))
1123 (if (get-text-property start 'keymap)
1124 (setq start next)
1125 (put-text-property start (or next (point)) 'keymap shr-map)))))
1126
1127 (defun shr-encode-url (url)
1128 "Encode URL."
1129 (browse-url-url-encode-chars url "[)$ ]"))
1130
1131 (autoload 'shr-color-visible "shr-color")
1132 (autoload 'shr-color->hexadecimal "shr-color")
1133
1134 (defun shr-color-check (fg bg)
1135 "Check that FG is visible on BG.
1136 Returns (fg bg) with corrected values.
1137 Returns nil if the colors that would be used are the default
1138 ones, in case fg and bg are nil."
1139 (when (or fg bg)
1140 (let ((fixed (cond ((null fg) 'fg)
1141 ((null bg) 'bg))))
1142 ;; Convert colors to hexadecimal, or set them to default.
1143 (let ((fg (or (shr-color->hexadecimal fg)
1144 (frame-parameter nil 'foreground-color)))
1145 (bg (or (shr-color->hexadecimal bg)
1146 (frame-parameter nil 'background-color))))
1147 (cond ((eq fixed 'bg)
1148 ;; Only return the new fg
1149 (list nil (cadr (shr-color-visible bg fg t))))
1150 ((eq fixed 'fg)
1151 ;; Invert args and results and return only the new bg
1152 (list (cadr (shr-color-visible fg bg t)) nil))
1153 (t
1154 (shr-color-visible bg fg)))))))
1155
1156 (defun shr-colorize-region (start end fg &optional bg)
1157 (when (and shr-use-colors
1158 (or fg bg)
1159 (>= (display-color-cells) 88))
1160 (let ((new-colors (shr-color-check fg bg)))
1161 (when new-colors
1162 (when fg
1163 (add-face-text-property start end
1164 (list :foreground (cadr new-colors))
1165 t))
1166 (when bg
1167 (add-face-text-property start end
1168 (list :background (car new-colors))
1169 t)))
1170 new-colors)))
1171
1172 ;;; Tag-specific rendering rules.
1173
1174 (defun shr-tag-html (dom)
1175 (let ((dir (dom-attr dom 'dir)))
1176 (cond
1177 ((equal dir "ltr")
1178 (setq bidi-paragraph-direction 'left-to-right))
1179 ((equal dir "rtl")
1180 (setq bidi-paragraph-direction 'right-to-left))
1181 ((equal dir "auto")
1182 (setq bidi-paragraph-direction nil))))
1183 (shr-generic dom))
1184
1185 (defun shr-tag-body (dom)
1186 (let* ((start (point))
1187 (fgcolor (or (dom-attr dom 'fgcolor) (dom-attr dom 'text)))
1188 (bgcolor (dom-attr dom 'bgcolor))
1189 (shr-stylesheet (list (cons 'color fgcolor)
1190 (cons 'background-color bgcolor))))
1191 (shr-generic dom)
1192 (shr-colorize-region start (point) fgcolor bgcolor)))
1193
1194 (defun shr-tag-style (_dom)
1195 )
1196
1197 (defun shr-tag-script (_dom)
1198 )
1199
1200 (defun shr-tag-comment (_dom)
1201 )
1202
1203 (defun shr-dom-to-xml (dom)
1204 (with-temp-buffer
1205 (shr-dom-print dom)
1206 (buffer-string)))
1207
1208 (defun shr-dom-print (dom)
1209 "Convert DOM into a string containing the xml representation."
1210 (insert (format "<%s" (dom-tag dom)))
1211 (dolist (attr (dom-attributes dom))
1212 ;; Ignore attributes that start with a colon because they are
1213 ;; private elements.
1214 (unless (= (aref (format "%s" (car attr)) 0) ?:)
1215 (insert (format " %s=\"%s\"" (car attr) (cdr attr)))))
1216 (insert ">")
1217 (let (url)
1218 (dolist (elem (dom-children dom))
1219 (cond
1220 ((stringp elem)
1221 (insert elem))
1222 ((eq (dom-tag elem) 'comment)
1223 )
1224 ((or (not (eq (dom-tag elem) 'image))
1225 ;; Filter out blocked elements inside the SVG image.
1226 (not (setq url (dom-attr elem ':xlink:href)))
1227 (not shr-blocked-images)
1228 (not (string-match shr-blocked-images url)))
1229 (insert " ")
1230 (shr-dom-print elem)))))
1231 (insert (format "</%s>" (dom-tag dom))))
1232
1233 (defun shr-tag-svg (dom)
1234 (when (and (image-type-available-p 'svg)
1235 (not shr-inhibit-images)
1236 (dom-attr dom 'width)
1237 (dom-attr dom 'height))
1238 (funcall shr-put-image-function (list (shr-dom-to-xml dom) 'image/svg+xml)
1239 "SVG Image")))
1240
1241 (defun shr-tag-sup (dom)
1242 (let ((start (point)))
1243 (shr-generic dom)
1244 (put-text-property start (point) 'display '(raise 0.5))))
1245
1246 (defun shr-tag-sub (dom)
1247 (let ((start (point)))
1248 (shr-generic dom)
1249 (put-text-property start (point) 'display '(raise -0.5))))
1250
1251 (defun shr-tag-label (dom)
1252 (shr-generic dom)
1253 (shr-ensure-paragraph))
1254
1255 (defun shr-tag-p (dom)
1256 (shr-ensure-paragraph)
1257 (shr-generic dom)
1258 (shr-ensure-paragraph))
1259
1260 (defun shr-tag-div (dom)
1261 (shr-ensure-newline)
1262 (shr-generic dom)
1263 (shr-ensure-newline))
1264
1265 (defun shr-tag-s (dom)
1266 (shr-fontize-dom dom 'shr-strike-through))
1267
1268 (defun shr-tag-b (dom)
1269 (shr-fontize-dom dom 'bold))
1270
1271 (defun shr-tag-i (dom)
1272 (shr-fontize-dom dom 'italic))
1273
1274 (defun shr-tag-em (dom)
1275 (shr-fontize-dom dom 'italic))
1276
1277 (defun shr-tag-strong (dom)
1278 (shr-fontize-dom dom 'bold))
1279
1280 (defun shr-tag-u (dom)
1281 (shr-fontize-dom dom 'underline))
1282
1283 (defun shr-tag-tt (dom)
1284 (let ((shr-current-font 'default))
1285 (shr-generic dom)))
1286
1287 (defun shr-tag-ins (cont)
1288 (let* ((start (point))
1289 (color "green")
1290 (shr-stylesheet (nconc (list (cons 'color color))
1291 shr-stylesheet)))
1292 (shr-generic cont)
1293 (shr-colorize-region start (point) color
1294 (cdr (assq 'background-color shr-stylesheet)))))
1295
1296 (defun shr-tag-del (cont)
1297 (let* ((start (point))
1298 (color "red")
1299 (shr-stylesheet (nconc (list (cons 'color color))
1300 shr-stylesheet)))
1301 (shr-fontize-dom cont 'shr-strike-through)
1302 (shr-colorize-region start (point) color
1303 (cdr (assq 'background-color shr-stylesheet)))))
1304
1305 (defun shr-parse-style (style)
1306 (when style
1307 (save-match-data
1308 (when (string-match "\n" style)
1309 (setq style (replace-match " " t t style))))
1310 (let ((plist nil))
1311 (dolist (elem (split-string style ";"))
1312 (when elem
1313 (setq elem (split-string elem ":"))
1314 (when (and (car elem)
1315 (cadr elem))
1316 (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem)))
1317 (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem))))
1318 (when (string-match " *!important\\'" value)
1319 (setq value (substring value 0 (match-beginning 0))))
1320 (unless (equal value "inherit")
1321 (push (cons (intern name obarray)
1322 value)
1323 plist))))))
1324 plist)))
1325
1326 (defun shr-tag-base (dom)
1327 (when-let (base (dom-attr dom 'href))
1328 (setq shr-base (shr-parse-base base)))
1329 (shr-generic dom))
1330
1331 (defun shr-tag-a (dom)
1332 (let ((url (dom-attr dom 'href))
1333 (title (dom-attr dom 'title))
1334 (start (point))
1335 shr-start)
1336 (shr-generic dom)
1337 (when (and shr-target-id
1338 (equal (dom-attr dom 'name) shr-target-id))
1339 ;; We have a zero-length <a name="foo"> element, so just
1340 ;; insert... something.
1341 (when (= start (point))
1342 (shr-ensure-newline)
1343 (insert " "))
1344 (put-text-property start (1+ start) 'shr-target-id shr-target-id))
1345 (when url
1346 (shr-urlify (or shr-start start) (shr-expand-url url) title))))
1347
1348 (defun shr-tag-object (dom)
1349 (unless shr-inhibit-images
1350 (let ((start (point))
1351 url multimedia image)
1352 (when-let (type (dom-attr dom 'type))
1353 (when (string-match "\\`image/svg" type)
1354 (setq url (dom-attr dom 'data)
1355 image t)))
1356 (dolist (child (dom-non-text-children dom))
1357 (cond
1358 ((eq (dom-tag child) 'embed)
1359 (setq url (or url (dom-attr child 'src))
1360 multimedia t))
1361 ((and (eq (dom-tag child) 'param)
1362 (equal (dom-attr child 'name) "movie"))
1363 (setq url (or url (dom-attr child 'value))
1364 multimedia t))))
1365 (when url
1366 (cond
1367 (image
1368 (shr-tag-img dom url)
1369 (setq dom nil))
1370 (multimedia
1371 (shr-insert " [multimedia] ")
1372 (shr-urlify start (shr-expand-url url)))))
1373 (when dom
1374 (shr-generic dom)))))
1375
1376 (defcustom shr-prefer-media-type-alist '(("webm" . 1.0)
1377 ("ogv" . 1.0)
1378 ("ogg" . 1.0)
1379 ("opus" . 1.0)
1380 ("flac" . 0.9)
1381 ("wav" . 0.5))
1382 "Preferences for media types.
1383 The key element should be a regexp matched against the type of the source or
1384 url if no type is specified. The value should be a float in the range 0.0 to
1385 1.0. Media elements with higher value are preferred."
1386 :version "24.4"
1387 :group 'shr
1388 :type '(alist :key-type regexp :value-type float))
1389
1390 (defun shr--get-media-pref (elem)
1391 "Determine the preference for ELEM.
1392 The preference is a float determined from `shr-prefer-media-type'."
1393 (let ((type (dom-attr elem 'type))
1394 (p 0.0))
1395 (unless type
1396 (setq type (dom-attr elem 'src)))
1397 (when type
1398 (dolist (pref shr-prefer-media-type-alist)
1399 (when (and
1400 (> (cdr pref) p)
1401 (string-match-p (car pref) type))
1402 (setq p (cdr pref)))))
1403 p))
1404
1405 (defun shr--extract-best-source (dom &optional url pref)
1406 "Extract the best `:src' property from <source> blocks in DOM."
1407 (setq pref (or pref -1.0))
1408 (let (new-pref)
1409 (dolist (elem (dom-non-text-children dom))
1410 (when (and (eq (dom-tag elem) 'source)
1411 (< pref
1412 (setq new-pref
1413 (shr--get-media-pref elem))))
1414 (setq pref new-pref
1415 url (dom-attr elem 'src))
1416 ;; libxml's html parser isn't HTML5 compliant and non terminated
1417 ;; source tags might end up as children. So recursion it is...
1418 (dolist (child (dom-non-text-children elem))
1419 (when (eq (dom-tag child) 'source)
1420 (let ((ret (shr--extract-best-source (list child) url pref)))
1421 (when (< pref (cdr ret))
1422 (setq url (car ret)
1423 pref (cdr ret)))))))))
1424 (cons url pref))
1425
1426 (defun shr-tag-video (dom)
1427 (let ((image (dom-attr dom 'poster))
1428 (url (dom-attr dom 'src))
1429 (start (point)))
1430 (unless url
1431 (setq url (car (shr--extract-best-source dom))))
1432 (if (> (length image) 0)
1433 (shr-tag-img nil image)
1434 (shr-insert " [video] "))
1435 (shr-urlify start (shr-expand-url url))))
1436
1437 (defun shr-tag-audio (dom)
1438 (let ((url (dom-attr dom 'src))
1439 (start (point)))
1440 (unless url
1441 (setq url (car (shr--extract-best-source dom))))
1442 (shr-insert " [audio] ")
1443 (shr-urlify start (shr-expand-url url))))
1444
1445 (defun shr-tag-img (dom &optional url)
1446 (when (or url
1447 (and dom
1448 (> (length (dom-attr dom 'src)) 0)))
1449 (when (> (current-column) 0)
1450 (insert "\n"))
1451 (let ((alt (dom-attr dom 'alt))
1452 (width (shr-string-number (dom-attr dom 'width)))
1453 (height (shr-string-number (dom-attr dom 'height)))
1454 (url (shr-expand-url (or url (dom-attr dom 'src)))))
1455 (let ((start (point-marker)))
1456 (when (zerop (length alt))
1457 (setq alt "*"))
1458 (cond
1459 ((or (member (dom-attr dom 'height) '("0" "1"))
1460 (member (dom-attr dom 'width) '("0" "1")))
1461 ;; Ignore zero-sized or single-pixel images.
1462 )
1463 ((and (not shr-inhibit-images)
1464 (string-match "\\`data:" url))
1465 (let ((image (shr-image-from-data (substring url (match-end 0)))))
1466 (if image
1467 (funcall shr-put-image-function image alt
1468 (list :width width :height height))
1469 (insert alt))))
1470 ((and (not shr-inhibit-images)
1471 (string-match "\\`cid:" url))
1472 (let ((url (substring url (match-end 0)))
1473 image)
1474 (if (or (not shr-content-function)
1475 (not (setq image (funcall shr-content-function url))))
1476 (insert alt)
1477 (funcall shr-put-image-function image alt
1478 (list :width width :height height)))))
1479 ((or shr-inhibit-images
1480 (and shr-blocked-images
1481 (string-match shr-blocked-images url)))
1482 (setq shr-start (point))
1483 (shr-insert alt))
1484 ((and (not shr-ignore-cache)
1485 (url-is-cached (shr-encode-url url)))
1486 (funcall shr-put-image-function (shr-get-image-data url) alt
1487 (list :width width :height height)))
1488 (t
1489 (when (and shr-ignore-cache
1490 (url-is-cached (shr-encode-url url)))
1491 (let ((file (url-cache-create-filename (shr-encode-url url))))
1492 (when (file-exists-p file)
1493 (delete-file file))))
1494 (when (image-type-available-p 'svg)
1495 (insert-image
1496 (shr-make-placeholder-image dom)
1497 (or alt "")))
1498 (insert " ")
1499 (url-queue-retrieve
1500 (shr-encode-url url) 'shr-image-fetched
1501 (list (current-buffer) start (set-marker (make-marker) (point))
1502 (list :width width :height height))
1503 t t)))
1504 (when (zerop shr-table-depth) ;; We are not in a table.
1505 (put-text-property start (point) 'keymap shr-image-map)
1506 (put-text-property start (point) 'shr-alt alt)
1507 (put-text-property start (point) 'image-url url)
1508 (put-text-property start (point) 'image-displayer
1509 (shr-image-displayer shr-content-function))
1510 (put-text-property start (point) 'help-echo
1511 (shr-fill-text
1512 (or (dom-attr dom 'title) alt))))))))
1513
1514 (defun shr-string-number (string)
1515 (if (null string)
1516 nil
1517 (setq string (replace-regexp-in-string "[^0-9]" "" string))
1518 (if (zerop (length string))
1519 nil
1520 (string-to-number string))))
1521
1522 (defun shr-make-placeholder-image (dom)
1523 (let* ((edges (and
1524 (get-buffer-window (current-buffer))
1525 (window-inside-pixel-edges
1526 (get-buffer-window (current-buffer)))))
1527 (scaling (image-compute-scaling-factor image-scaling-factor))
1528 (width (truncate
1529 (* (or (shr-string-number (dom-attr dom 'width)) 100)
1530 scaling)))
1531 (height (truncate
1532 (* (or (shr-string-number (dom-attr dom 'height)) 100)
1533 scaling)))
1534 (max-width
1535 (and edges
1536 (truncate (* shr-max-image-proportion
1537 (- (nth 2 edges) (nth 0 edges))))))
1538 (max-height (and edges
1539 (truncate (* shr-max-image-proportion
1540 (- (nth 3 edges) (nth 1 edges))))))
1541 svg image)
1542 (when (and max-width
1543 (> width max-width))
1544 (setq height (truncate (* (/ (float max-width) width) height))
1545 width max-width))
1546 (when (and max-height
1547 (> height max-height))
1548 (setq width (truncate (* (/ (float max-height) height) width))
1549 height max-height))
1550 (setq svg (svg-create width height))
1551 (svg-gradient svg "background" 'linear '((0 . "#b0b0b0") (100 . "#808080")))
1552 (svg-rectangle svg 0 0 width height :gradient "background"
1553 :stroke-width 2 :stroke-color "black")
1554 (let ((image (svg-image svg)))
1555 (setf (image-property image :ascent) 100)
1556 image)))
1557
1558 (defun shr-tag-pre (dom)
1559 (let ((shr-folding-mode 'none)
1560 (shr-current-font 'default))
1561 (shr-ensure-newline)
1562 (shr-generic dom)
1563 (shr-ensure-newline)))
1564
1565 (defun shr-tag-blockquote (dom)
1566 (shr-ensure-paragraph)
1567 (let ((start (point))
1568 (shr-indentation (+ shr-indentation
1569 (* 4 shr-table-separator-pixel-width))))
1570 (shr-generic dom)
1571 (shr-ensure-paragraph)
1572 (shr-mark-fill start)))
1573
1574 (defun shr-tag-dl (dom)
1575 (shr-ensure-paragraph)
1576 (shr-generic dom)
1577 (shr-ensure-paragraph))
1578
1579 (defun shr-tag-dt (dom)
1580 (shr-ensure-newline)
1581 (shr-generic dom)
1582 (shr-ensure-newline))
1583
1584 (defun shr-tag-dd (dom)
1585 (shr-ensure-newline)
1586 (let ((shr-indentation (+ shr-indentation
1587 (* 4 shr-table-separator-pixel-width))))
1588 (shr-generic dom)))
1589
1590 (defun shr-tag-ul (dom)
1591 (shr-ensure-paragraph)
1592 (let ((shr-list-mode 'ul))
1593 (shr-generic dom))
1594 ;; If we end on an empty <li>, then make sure we really end on a new
1595 ;; paragraph.
1596 (unless (bolp)
1597 (insert "\n"))
1598 (shr-ensure-paragraph))
1599
1600 (defun shr-tag-ol (dom)
1601 (shr-ensure-paragraph)
1602 (let ((shr-list-mode 1))
1603 (shr-generic dom))
1604 (shr-ensure-paragraph))
1605
1606 (defun shr-tag-li (dom)
1607 (shr-ensure-newline)
1608 (let ((start (point)))
1609 (let* ((bullet
1610 (if (numberp shr-list-mode)
1611 (prog1
1612 (format "%d " shr-list-mode)
1613 (setq shr-list-mode (1+ shr-list-mode)))
1614 (car shr-internal-bullet)))
1615 (width (if (numberp shr-list-mode)
1616 (shr-string-pixel-width bullet)
1617 (cdr shr-internal-bullet))))
1618 (insert bullet)
1619 (shr-mark-fill start)
1620 (let ((shr-indentation (+ shr-indentation width)))
1621 (put-text-property start (1+ start)
1622 'shr-continuation-indentation shr-indentation)
1623 (put-text-property start (1+ start) 'shr-prefix-length (length bullet))
1624 (shr-generic dom))))
1625 (unless (bolp)
1626 (insert "\n")))
1627
1628 (defun shr-mark-fill (start)
1629 ;; We may not have inserted any text to fill.
1630 (unless (= start (point))
1631 (put-text-property start (1+ start)
1632 'shr-indentation shr-indentation)))
1633
1634 (defun shr-tag-br (dom)
1635 (when (and (not (bobp))
1636 ;; Only add a newline if we break the current line, or
1637 ;; the previous line isn't a blank line.
1638 (or (not (bolp))
1639 (and (> (- (point) 2) (point-min))
1640 (not (= (char-after (- (point) 2)) ?\n)))))
1641 (insert "\n"))
1642 (shr-generic dom))
1643
1644 (defun shr-tag-span (dom)
1645 (shr-generic dom))
1646
1647 (defun shr-tag-h1 (dom)
1648 (shr-heading dom (if shr-use-fonts
1649 '(variable-pitch (:height 1.3 :weight bold))
1650 'bold)))
1651
1652 (defun shr-tag-h2 (dom)
1653 (shr-heading dom 'bold))
1654
1655 (defun shr-tag-h3 (dom)
1656 (shr-heading dom 'italic))
1657
1658 (defun shr-tag-h4 (dom)
1659 (shr-heading dom))
1660
1661 (defun shr-tag-h5 (dom)
1662 (shr-heading dom))
1663
1664 (defun shr-tag-h6 (dom)
1665 (shr-heading dom))
1666
1667 (defun shr-tag-hr (_dom)
1668 (shr-ensure-newline)
1669 (insert (make-string (if (not shr-use-fonts)
1670 shr-internal-width
1671 (1+ (/ shr-internal-width
1672 shr-table-separator-pixel-width)))
1673 shr-hr-line)
1674 "\n"))
1675
1676 (defun shr-tag-title (dom)
1677 (shr-heading dom 'bold 'underline))
1678
1679 (defun shr-tag-font (dom)
1680 (let* ((start (point))
1681 (color (dom-attr dom 'color))
1682 (shr-stylesheet (nconc (list (cons 'color color))
1683 shr-stylesheet)))
1684 (shr-generic dom)
1685 (when color
1686 (shr-colorize-region start (point) color
1687 (cdr (assq 'background-color shr-stylesheet))))))
1688
1689 (defun shr-tag-bdo (dom)
1690 (let* ((direction (dom-attr dom 'dir))
1691 (char (cond
1692 ((equal direction "ltr")
1693 ?\N{LEFT-TO-RIGHT OVERRIDE})
1694 ((equal direction "rtl")
1695 ?\N{RIGHT-TO-LEFT OVERRIDE}))))
1696 (when char
1697 (insert ?\N{FIRST STRONG ISOLATE} char))
1698 (shr-generic dom)
1699 (when char
1700 (insert ?\N{POP DIRECTIONAL FORMATTING} ?\N{POP DIRECTIONAL ISOLATE}))))
1701
1702 (defun shr-tag-bdi (dom)
1703 (insert ?\N{FIRST STRONG ISOLATE})
1704 (shr-generic dom)
1705 (insert ?\N{POP DIRECTIONAL ISOLATE}))
1706
1707 ;;; Table rendering algorithm.
1708
1709 ;; Table rendering is the only complicated thing here. We do this by
1710 ;; first counting how many TDs there are in each TR, and registering
1711 ;; how wide they think they should be ("width=45%", etc). Then we
1712 ;; render each TD separately (this is done in temporary buffers, so
1713 ;; that we can use all the rendering machinery as if we were in the
1714 ;; main buffer). Now we know how much space each TD really takes, so
1715 ;; we then render everything again with the new widths, and finally
1716 ;; insert all these boxes into the main buffer.
1717 (defun shr-tag-table-1 (dom)
1718 (setq dom (or (dom-child-by-tag dom 'tbody) dom))
1719 (let* ((shr-inhibit-images t)
1720 (shr-table-depth (1+ shr-table-depth))
1721 (shr-kinsoku-shorten t)
1722 ;; Find all suggested widths.
1723 (columns (shr-column-specs dom))
1724 ;; Compute how many pixels wide each TD should be.
1725 (suggested-widths (shr-pro-rate-columns columns))
1726 ;; Do a "test rendering" to see how big each TD is (this can
1727 ;; be smaller (if there's little text) or bigger (if there's
1728 ;; unbreakable text).
1729 (elems (or (dom-attr dom 'shr-suggested-widths)
1730 (shr-make-table dom suggested-widths nil
1731 'shr-suggested-widths)))
1732 (sketch (loop for line in elems
1733 collect (mapcar #'car line)))
1734 (natural (loop for line in elems
1735 collect (mapcar #'cdr line)))
1736 (sketch-widths (shr-table-widths sketch natural suggested-widths)))
1737 ;; This probably won't work very well.
1738 (when (> (+ (loop for width across sketch-widths
1739 summing (1+ width))
1740 shr-indentation shr-table-separator-pixel-width)
1741 (frame-width))
1742 (setq truncate-lines t))
1743 ;; Then render the table again with these new "hard" widths.
1744 (shr-insert-table (shr-make-table dom sketch-widths t) sketch-widths)))
1745
1746 (defun shr-table-body (dom)
1747 (let ((tbodies (seq-filter (lambda (child)
1748 (eq (dom-tag child) 'tbody))
1749 (dom-non-text-children dom))))
1750 (cond
1751 ((null tbodies)
1752 dom)
1753 ((= (length tbodies) 1)
1754 (car tbodies))
1755 (t
1756 ;; Table with multiple tbodies. Convert into a single tbody.
1757 `(tbody nil ,@(cl-reduce 'append
1758 (mapcar 'dom-non-text-children tbodies)))))))
1759
1760 (defun shr-tag-table (dom)
1761 (shr-ensure-paragraph)
1762 (let* ((caption (dom-children (dom-child-by-tag dom 'caption)))
1763 (header (dom-non-text-children (dom-child-by-tag dom 'thead)))
1764 (body (dom-non-text-children (shr-table-body dom)))
1765 (footer (dom-non-text-children (dom-child-by-tag dom 'tfoot)))
1766 (bgcolor (dom-attr dom 'bgcolor))
1767 (start (point))
1768 (shr-stylesheet (nconc (list (cons 'background-color bgcolor))
1769 shr-stylesheet))
1770 (nheader (if header (shr-max-columns header)))
1771 (nbody (if body (shr-max-columns body) 0))
1772 (nfooter (if footer (shr-max-columns footer))))
1773 (if (and (not caption)
1774 (not header)
1775 (not (dom-child-by-tag dom 'tbody))
1776 (not (dom-child-by-tag dom 'tr))
1777 (not footer))
1778 ;; The table is totally invalid and just contains random junk.
1779 ;; Try to output it anyway.
1780 (shr-generic dom)
1781 ;; It's a real table, so render it.
1782 (if (dom-attr dom 'shr-fixed-table)
1783 (shr-tag-table-1 dom)
1784 ;; Only fix up the table once.
1785 (let ((table
1786 (nconc
1787 (list 'table nil)
1788 (if caption `((tr nil (td nil ,@caption))))
1789 (cond
1790 (header
1791 (if footer
1792 ;; header + body + footer
1793 (if (= nheader nbody)
1794 (if (= nbody nfooter)
1795 `((tr nil (td nil (table nil
1796 (tbody nil ,@header
1797 ,@body ,@footer)))))
1798 (nconc `((tr nil (td nil (table nil
1799 (tbody nil ,@header
1800 ,@body)))))
1801 (if (= nfooter 1)
1802 footer
1803 `((tr nil (td nil (table
1804 nil (tbody
1805 nil ,@footer))))))))
1806 (nconc `((tr nil (td nil (table nil (tbody
1807 nil ,@header)))))
1808 (if (= nbody nfooter)
1809 `((tr nil (td nil (table
1810 nil (tbody nil ,@body
1811 ,@footer)))))
1812 (nconc `((tr nil (td nil (table
1813 nil (tbody nil
1814 ,@body)))))
1815 (if (= nfooter 1)
1816 footer
1817 `((tr nil (td nil (table
1818 nil
1819 (tbody
1820 nil
1821 ,@footer))))))))))
1822 ;; header + body
1823 (if (= nheader nbody)
1824 `((tr nil (td nil (table nil (tbody nil ,@header
1825 ,@body)))))
1826 (if (= nheader 1)
1827 `(,@header (tr nil (td nil (table
1828 nil (tbody nil ,@body)))))
1829 `((tr nil (td nil (table nil (tbody nil ,@header))))
1830 (tr nil (td nil (table nil (tbody nil ,@body)))))))))
1831 (footer
1832 ;; body + footer
1833 (if (= nbody nfooter)
1834 `((tr nil (td nil (table
1835 nil (tbody nil ,@body ,@footer)))))
1836 (nconc `((tr nil (td nil (table nil (tbody nil ,@body)))))
1837 (if (= nfooter 1)
1838 footer
1839 `((tr nil (td nil (table
1840 nil (tbody nil ,@footer)))))))))
1841 (caption
1842 `((tr nil (td nil (table nil (tbody nil ,@body))))))
1843 (body)))))
1844 (dom-set-attribute table 'shr-fixed-table t)
1845 (setcdr dom (cdr table))
1846 (shr-tag-table-1 dom))))
1847 (when bgcolor
1848 (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
1849 bgcolor))
1850 ;; Finally, insert all the images after the table. The Emacs buffer
1851 ;; model isn't strong enough to allow us to put the images actually
1852 ;; into the tables.
1853 (when (zerop shr-table-depth)
1854 (save-excursion
1855 (shr-expand-alignments start (point)))
1856 (dolist (elem (dom-by-tag dom 'object))
1857 (shr-tag-object elem))
1858 (dolist (elem (dom-by-tag dom 'img))
1859 (shr-tag-img elem)))))
1860
1861 (defun shr-insert-table (table widths)
1862 (let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet))
1863 "collapse"))
1864 (shr-table-separator-length (if collapse 0 1))
1865 (shr-table-vertical-line (if collapse "" shr-table-vertical-line))
1866 (start (point)))
1867 (setq shr-table-id (1+ shr-table-id))
1868 (unless collapse
1869 (shr-insert-table-ruler widths))
1870 (dolist (row table)
1871 (let ((start (point))
1872 (align 0)
1873 (column-number 0)
1874 (height (let ((max 0))
1875 (dolist (column row)
1876 (setq max (max max (nth 2 column))))
1877 max)))
1878 (dotimes (i (max height 1))
1879 (shr-indent)
1880 (insert shr-table-vertical-line "\n"))
1881 (dolist (column row)
1882 (when (> (nth 2 column) -1)
1883 (goto-char start)
1884 ;; Sum up all the widths from the column. (There may be
1885 ;; more than one if this is a "colspan" column.)
1886 (dotimes (i (nth 4 column))
1887 ;; The colspan directive may be wrong and there may not be
1888 ;; that number of columns.
1889 (when (<= column-number (1- (length widths)))
1890 (setq align (+ align
1891 (aref widths column-number)
1892 (* 2 shr-table-separator-pixel-width))))
1893 (setq column-number (1+ column-number)))
1894 (let ((lines (nth 3 column))
1895 (pixel-align (if (not shr-use-fonts)
1896 (* align (frame-char-width))
1897 align)))
1898 (dolist (line lines)
1899 (end-of-line)
1900 (let ((start (point))
1901 (background (and (> (length line) 0)
1902 (shr-face-background
1903 (get-text-property
1904 (1- (length line)) 'face line))))
1905 (space (propertize
1906 " "
1907 'display `(space :align-to (,pixel-align))
1908 'shr-table-indent shr-table-id)))
1909 (when background
1910 (setq space (propertize space 'face background)))
1911 (insert line space shr-table-vertical-line)
1912 (shr-colorize-region
1913 start (1- (point)) (nth 5 column) (nth 6 column)))
1914 (forward-line 1))
1915 ;; Add blank lines at padding at the bottom of the TD,
1916 ;; possibly.
1917 (dotimes (i (- height (length lines)))
1918 (end-of-line)
1919 (let ((start (point)))
1920 (insert (propertize " "
1921 'display `(space :align-to (,pixel-align))
1922 'shr-table-indent shr-table-id)
1923 shr-table-vertical-line)
1924 (shr-colorize-region
1925 start (1- (point)) (nth 5 column) (nth 6 column)))
1926 (forward-line 1))))))
1927 (unless collapse
1928 (shr-insert-table-ruler widths)))
1929 (unless (= start (point))
1930 (put-text-property start (1+ start) 'shr-table-id shr-table-id))))
1931
1932 (defun shr-face-background (face)
1933 (and (consp face)
1934 (or (and (plist-get face :background)
1935 (list :background (plist-get face :background)))
1936 (let ((background nil))
1937 (dolist (elem face)
1938 (when (and (consp elem)
1939 (eq (car elem) :background)
1940 (not background))
1941 (setq background (cadr elem))))
1942 (and background
1943 (list :background background))))))
1944
1945 (defun shr-expand-alignments (start end)
1946 (while (< (setq start (next-single-property-change
1947 start 'shr-table-id nil end))
1948 end)
1949 (goto-char start)
1950 (let* ((shr-use-fonts t)
1951 (id (get-text-property (point) 'shr-table-id))
1952 (base (shr-pixel-column))
1953 elem)
1954 (when id
1955 (save-excursion
1956 (while (setq elem (text-property-any
1957 (point) end 'shr-table-indent id))
1958 (goto-char elem)
1959 (let ((align (get-text-property (point) 'display)))
1960 (put-text-property (point) (1+ (point)) 'display
1961 `(space :align-to (,(+ (car (nth 2 align))
1962 base)))))
1963 (forward-char 1)))))
1964 (setq start (1+ start))))
1965
1966 (defun shr-insert-table-ruler (widths)
1967 (when shr-table-horizontal-line
1968 (when (and (bolp)
1969 (> shr-indentation 0))
1970 (shr-indent))
1971 (insert shr-table-corner)
1972 (let ((total-width 0))
1973 (dotimes (i (length widths))
1974 (setq total-width (+ total-width (aref widths i)
1975 (* shr-table-separator-pixel-width 2)))
1976 (insert (make-string (1+ (/ (aref widths i)
1977 shr-table-separator-pixel-width))
1978 shr-table-horizontal-line)
1979 (propertize " "
1980 'display `(space :align-to (,total-width))
1981 'shr-table-indent shr-table-id)
1982 shr-table-corner)))
1983 (insert "\n")))
1984
1985 (defun shr-table-widths (table natural-table suggested-widths)
1986 (let* ((length (length suggested-widths))
1987 (widths (make-vector length 0))
1988 (natural-widths (make-vector length 0)))
1989 (dolist (row table)
1990 (let ((i 0))
1991 (dolist (column row)
1992 (aset widths i (max (aref widths i) column))
1993 (setq i (1+ i)))))
1994 (dolist (row natural-table)
1995 (let ((i 0))
1996 (dolist (column row)
1997 (aset natural-widths i (max (aref natural-widths i) column))
1998 (setq i (1+ i)))))
1999 (let ((extra (- (apply '+ (append suggested-widths nil))
2000 (apply '+ (append widths nil))
2001 (* shr-table-separator-pixel-width (1+ (length widths)))))
2002 (expanded-columns 0))
2003 ;; We have extra, unused space, so divide this space amongst the
2004 ;; columns.
2005 (when (> extra 0)
2006 ;; If the natural width is wider than the rendered width, we
2007 ;; want to allow the column to expand.
2008 (dotimes (i length)
2009 (when (> (aref natural-widths i) (aref widths i))
2010 (setq expanded-columns (1+ expanded-columns))))
2011 (dotimes (i length)
2012 (when (> (aref natural-widths i) (aref widths i))
2013 (aset widths i (min
2014 (aref natural-widths i)
2015 (+ (/ extra expanded-columns)
2016 (aref widths i))))))))
2017 widths))
2018
2019 (defun shr-make-table (dom widths &optional fill storage-attribute)
2020 (or (cadr (assoc (list dom widths fill) shr-content-cache))
2021 (let ((data (shr-make-table-1 dom widths fill)))
2022 (push (list (list dom widths fill) data)
2023 shr-content-cache)
2024 (when storage-attribute
2025 (dom-set-attribute dom storage-attribute data))
2026 data)))
2027
2028 (defun shr-make-table-1 (dom widths &optional fill)
2029 (let ((trs nil)
2030 (rowspans (make-vector (length widths) 0))
2031 (colspan-remaining 0)
2032 colspan-width colspan-count
2033 width colspan)
2034 (dolist (row (dom-non-text-children dom))
2035 (when (eq (dom-tag row) 'tr)
2036 (let ((tds nil)
2037 (columns (dom-non-text-children row))
2038 (i 0)
2039 (width-column 0)
2040 column)
2041 (while (< i (length widths))
2042 ;; If we previously had a rowspan definition, then that
2043 ;; means that we now have a "missing" td/th element here.
2044 ;; So just insert a dummy, empty one to (sort of) emulate
2045 ;; rowspan.
2046 (setq column
2047 (if (zerop (aref rowspans i))
2048 (pop columns)
2049 (aset rowspans i (1- (aref rowspans i)))
2050 '(td)))
2051 (when (and (not (stringp column))
2052 (or (memq (dom-tag column) '(td th))
2053 (not column)))
2054 (when-let (span (dom-attr column 'rowspan))
2055 (aset rowspans i (+ (aref rowspans i)
2056 (1- (string-to-number span)))))
2057 ;; Sanity check for invalid column-spans.
2058 (when (>= width-column (length widths))
2059 (setq width-column 0))
2060 (setq width
2061 (if column
2062 (aref widths width-column)
2063 (* 10 shr-table-separator-pixel-width)))
2064 (when (setq colspan (dom-attr column 'colspan))
2065 (setq colspan (min (string-to-number colspan)
2066 ;; The colspan may be wrong, so
2067 ;; truncate it to the length of the
2068 ;; remaining columns.
2069 (- (length widths) i)))
2070 (dotimes (j (1- colspan))
2071 (setq width
2072 (if (> (+ i 1 j) (1- (length widths)))
2073 ;; If we have a colspan spec that's longer
2074 ;; than the table is wide, just use the last
2075 ;; width as the width.
2076 (aref widths (1- (length widths)))
2077 ;; Sum up the widths of the columns we're
2078 ;; spanning.
2079 (+ width
2080 shr-table-separator-length
2081 (aref widths (+ i 1 j))))))
2082 (setq width-column (+ width-column (1- colspan))
2083 colspan-count colspan
2084 colspan-remaining colspan))
2085 (when column
2086 (let ((data (shr-render-td column width fill)))
2087 (if (and (not fill)
2088 (> colspan-remaining 0))
2089 (progn
2090 (setq colspan-width (car data))
2091 (let ((this-width (/ colspan-width colspan-count)))
2092 (push (cons this-width (cadr data)) tds)
2093 (setq colspan-remaining (1- colspan-remaining))))
2094 (if (not fill)
2095 (push (cons (car data) (cadr data)) tds)
2096 (push data tds)))))
2097 (when (and colspan
2098 (> colspan 1))
2099 (dotimes (c (1- colspan))
2100 (setq i (1+ i))
2101 (push
2102 (if fill
2103 (list 0 0 -1 nil 1 nil nil)
2104 '(0 . 0))
2105 tds)))
2106 (setq i (1+ i)
2107 width-column (1+ width-column))))
2108 (push (nreverse tds) trs))))
2109 (nreverse trs)))
2110
2111 (defun shr-pixel-buffer-width ()
2112 (if (not shr-use-fonts)
2113 (save-excursion
2114 (goto-char (point-min))
2115 (let ((max 0))
2116 (while (not (eobp))
2117 (end-of-line)
2118 (setq max (max max (current-column)))
2119 (forward-line 1))
2120 max))
2121 (if (get-buffer-window)
2122 (car (window-text-pixel-size nil (point-min) (point-max)))
2123 (save-window-excursion
2124 (set-window-buffer nil (current-buffer))
2125 (car (window-text-pixel-size nil (point-min) (point-max)))))))
2126
2127 (defun shr-render-td (dom width fill)
2128 (let ((cache (intern (format "shr-td-cache-%s-%s" width fill))))
2129 (or (dom-attr dom cache)
2130 (and fill
2131 (let (result)
2132 (dolist (attr (dom-attributes dom))
2133 (let ((name (symbol-name (car attr))))
2134 (when (string-match "shr-td-cache-\\([0-9]+\\)-nil" name)
2135 (let ((cache-width (string-to-number
2136 (match-string 1 name))))
2137 (when (and (>= cache-width width)
2138 (<= (car (cdr attr)) width))
2139 (setq result (cdr attr)))))))
2140 result))
2141 (let ((result (shr-render-td-1 dom width fill)))
2142 (dom-set-attribute dom cache result)
2143 result))))
2144
2145 (defun shr-render-td-1 (dom width fill)
2146 (with-temp-buffer
2147 (let ((bgcolor (dom-attr dom 'bgcolor))
2148 (fgcolor (dom-attr dom 'fgcolor))
2149 (style (dom-attr dom 'style))
2150 (shr-stylesheet shr-stylesheet)
2151 (max-width 0)
2152 natural-width)
2153 (when style
2154 (setq style (and (string-match "color" style)
2155 (shr-parse-style style))))
2156 (when bgcolor
2157 (setq style (nconc (list (cons 'background-color bgcolor))
2158 style)))
2159 (when fgcolor
2160 (setq style (nconc (list (cons 'color fgcolor)) style)))
2161 (when style
2162 (setq shr-stylesheet (append style shr-stylesheet)))
2163 (let ((shr-internal-width width)
2164 (shr-indentation 0))
2165 (shr-descend dom))
2166 (save-window-excursion
2167 (set-window-buffer nil (current-buffer))
2168 (unless fill
2169 (setq natural-width
2170 (or (dom-attr dom 'shr-td-cache-natural)
2171 (let ((natural (max (shr-pixel-buffer-width)
2172 (shr-dom-max-natural-width dom 0))))
2173 (dom-set-attribute dom 'shr-td-cache-natural natural)
2174 natural))))
2175 (if (and natural-width
2176 (<= natural-width width))
2177 (setq max-width natural-width)
2178 (let ((shr-internal-width width))
2179 (shr-fill-lines (point-min) (point-max))
2180 (setq max-width (shr-pixel-buffer-width)))))
2181 (goto-char (point-max))
2182 ;; Delete padding at the bottom of the TDs.
2183 (delete-region
2184 (point)
2185 (progn
2186 (skip-chars-backward " \t\n")
2187 (end-of-line)
2188 (point)))
2189 (goto-char (point-min))
2190 (list max-width
2191 natural-width
2192 (count-lines (point-min) (point-max))
2193 (split-string (buffer-string) "\n")
2194 (if (dom-attr dom 'colspan)
2195 (string-to-number (dom-attr dom 'colspan))
2196 1)
2197 (cdr (assq 'color shr-stylesheet))
2198 (cdr (assq 'background-color shr-stylesheet))))))
2199
2200 (defun shr-dom-max-natural-width (dom max)
2201 (if (eq (dom-tag dom) 'table)
2202 (max max (or
2203 (loop for line in (dom-attr dom 'shr-suggested-widths)
2204 maximize (+
2205 shr-table-separator-length
2206 (loop for elem in line
2207 summing
2208 (+ (cdr elem)
2209 (* 2 shr-table-separator-length)))))
2210 0))
2211 (dolist (child (dom-children dom))
2212 (unless (stringp child)
2213 (setq max (max (shr-dom-max-natural-width child max)))))
2214 max))
2215
2216 (defun shr-buffer-width ()
2217 (goto-char (point-min))
2218 (let ((max 0))
2219 (while (not (eobp))
2220 (end-of-line)
2221 (setq max (max max (current-column)))
2222 (forward-line 1))
2223 max))
2224
2225 (defun shr-pro-rate-columns (columns)
2226 (let ((total-percentage 0)
2227 (widths (make-vector (length columns) 0)))
2228 (dotimes (i (length columns))
2229 (setq total-percentage (+ total-percentage (aref columns i))))
2230 (setq total-percentage (/ 1.0 total-percentage))
2231 (dotimes (i (length columns))
2232 (aset widths i (max (truncate (* (aref columns i)
2233 total-percentage
2234 (- shr-internal-width
2235 (* (1+ (length columns))
2236 shr-table-separator-pixel-width))))
2237 10)))
2238 widths))
2239
2240 ;; Return a summary of the number and shape of the TDs in the table.
2241 (defun shr-column-specs (dom)
2242 (let ((columns (make-vector (shr-max-columns dom) 1)))
2243 (dolist (row (dom-non-text-children dom))
2244 (when (eq (dom-tag row) 'tr)
2245 (let ((i 0))
2246 (dolist (column (dom-non-text-children row))
2247 (when (memq (dom-tag column) '(td th))
2248 (let ((width (dom-attr column 'width)))
2249 (when (and width
2250 (string-match "\\([0-9]+\\)%" width)
2251 (not (zerop (setq width (string-to-number
2252 (match-string 1 width))))))
2253 (aset columns i (/ width 100.0))))
2254 (setq i (1+ i)))))))
2255 columns))
2256
2257 (defun shr-count (dom elem)
2258 (let ((i 0))
2259 (dolist (sub (dom-children dom))
2260 (when (and (not (stringp sub))
2261 (eq (dom-tag sub) elem))
2262 (setq i (1+ i))))
2263 i))
2264
2265 (defun shr-max-columns (dom)
2266 (let ((max 0))
2267 (dolist (row (dom-children dom))
2268 (when (and (not (stringp row))
2269 (eq (dom-tag row) 'tr))
2270 (setq max (max max (+ (shr-count row 'td)
2271 (shr-count row 'th))))))
2272 max))
2273
2274 (provide 'shr)
2275
2276 ;;; shr.el ends here