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