16c2936a154ee99b5765a087dcb55b6d9721df87
[gnus] / lisp / shr.el
1 ;;; shr.el --- Simple HTML Renderer
2
3 ;; Copyright (C) 2010-2013 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
37 (defgroup shr nil
38   "Simple HTML Renderer"
39   :version "24.1"
40   :group 'mail)
41
42 (defcustom shr-max-image-proportion 0.9
43   "How big pictures displayed are in relation to the window they're in.
44 A value of 0.7 means that they are allowed to take up 70% of the
45 width and height of the window.  If they are larger than this,
46 and Emacs supports it, then the images will be rescaled down to
47 fit these criteria."
48   :version "24.1"
49   :group 'shr
50   :type 'float)
51
52 (defcustom shr-blocked-images nil
53   "Images that have URLs matching this regexp will be blocked."
54   :version "24.1"
55   :group 'shr
56   :type '(choice (const nil) regexp))
57
58 (defcustom shr-table-horizontal-line ?\s
59   "Character used to draw horizontal table lines."
60   :group 'shr
61   :type 'character)
62
63 (defcustom shr-table-vertical-line ?\s
64   "Character used to draw vertical table lines."
65   :group 'shr
66   :type 'character)
67
68 (defcustom shr-table-corner ?\s
69   "Character used to draw table corners."
70   :group 'shr
71   :type 'character)
72
73 (defcustom shr-hr-line ?-
74   "Character used to draw hr lines."
75   :group 'shr
76   :type 'character)
77
78 (defcustom shr-width fill-column
79   "Frame width to use for rendering.
80 May either be an integer specifying a fixed width in characters,
81 or nil, meaning that the full width of the window should be
82 used."
83   :type '(choice (integer :tag "Fixed width in characters")
84                  (const   :tag "Use the width of the window" nil))
85   :group 'shr)
86
87 (defcustom shr-bullet "* "
88   "Bullet used for unordered lists.
89 Alternative suggestions are:
90 - \"  \"
91 - \"  \""
92   :type 'string
93   :group 'shr)
94
95 (defvar shr-content-function nil
96   "If bound, this should be a function that will return the content.
97 This is used for cid: URLs, and the function is called with the
98 cid: URL as the argument.")
99
100 (defvar shr-put-image-function 'shr-put-image
101   "Function called to put image and alt string.")
102
103 (defface shr-strike-through '((t (:strike-through t)))
104   "Font for <s> elements."
105   :group 'shr)
106
107 (defface shr-link
108   '((t (:inherit link)))
109   "Font for link elements."
110   :group 'shr)
111
112 ;;; Internal variables.
113
114 (defvar shr-folding-mode nil)
115 (defvar shr-state nil)
116 (defvar shr-start nil)
117 (defvar shr-indentation 0)
118 (defvar shr-inhibit-images nil)
119 (defvar shr-list-mode nil)
120 (defvar shr-content-cache nil)
121 (defvar shr-kinsoku-shorten nil)
122 (defvar shr-table-depth 0)
123 (defvar shr-stylesheet nil)
124 (defvar shr-base nil)
125 (defvar shr-ignore-cache nil)
126 (defvar shr-external-rendering-functions nil)
127 (defvar shr-target-id nil)
128 (defvar shr-inhibit-decoration nil)
129
130 (defvar shr-map
131   (let ((map (make-sparse-keymap)))
132     (define-key map "a" 'shr-show-alt-text)
133     (define-key map "i" 'shr-browse-image)
134     (define-key map "z" 'shr-zoom-image)
135     (define-key map [tab] 'shr-next-link)
136     (define-key map [backtab] 'shr-previous-link)
137     (define-key map "I" 'shr-insert-image)
138     (define-key map "u" 'shr-copy-url)
139     (define-key map "v" 'shr-browse-url)
140     (define-key map "o" 'shr-save-contents)
141     (define-key map "\r" 'shr-browse-url)
142     map))
143
144 ;; Public functions and commands.
145
146 (defun shr-render-buffer (buffer)
147   "Display the HTML rendering of the current buffer."
148   (interactive (list (current-buffer)))
149   (pop-to-buffer "*html*")
150   (erase-buffer)
151   (shr-insert-document
152    (with-current-buffer buffer
153      (libxml-parse-html-region (point-min) (point-max))))
154   (goto-char (point-min)))
155
156 (defun shr-visit-file (file)
157   "Parse FILE as an HTML document, and render it in a new buffer."
158   (interactive "fHTML file name: ")
159   (with-temp-buffer
160     (insert-file-contents file)
161     (shr-render-buffer (current-buffer))))
162
163 ;;;###autoload
164 (defun shr-insert-document (dom)
165   "Render the parsed document DOM into the current buffer.
166 DOM should be a parse tree as generated by
167 `libxml-parse-html-region' or similar."
168   (setq shr-content-cache nil)
169   (let ((start (point))
170         (shr-state nil)
171         (shr-start nil)
172         (shr-base nil)
173         (shr-preliminary-table-render 0)
174         (shr-width (or shr-width (window-width))))
175     (shr-descend (shr-transform-dom dom))
176     (shr-remove-trailing-whitespace start (point))))
177
178 (defun shr-remove-trailing-whitespace (start end)
179   (let ((width (window-width)))
180     (save-restriction
181       (narrow-to-region start end)
182       (goto-char start)
183       (while (not (eobp))
184         (end-of-line)
185         (when (> (shr-previous-newline-padding-width (current-column)) width)
186           (dolist (overlay (overlays-at (point)))
187             (when (overlay-get overlay 'before-string)
188               (overlay-put overlay 'before-string nil))))
189         (forward-line 1)))))
190
191 (defun shr-copy-url ()
192   "Copy the URL under point to the kill ring.
193 If called twice, then try to fetch the URL and see whether it
194 redirects somewhere else."
195   (interactive)
196   (let ((url (get-text-property (point) 'shr-url)))
197     (cond
198      ((not url)
199       (message "No URL under point"))
200      ;; Resolve redirected URLs.
201      ((equal url (car kill-ring))
202       (url-retrieve
203        url
204        (lambda (a)
205          (when (and (consp a)
206                     (eq (car a) :redirect))
207            (with-temp-buffer
208              (insert (cadr a))
209              (goto-char (point-min))
210              ;; Remove common tracking junk from the URL.
211              (when (re-search-forward ".utm_.*" nil t)
212                (replace-match "" t t))
213              (message "Copied %s" (buffer-string))
214              (copy-region-as-kill (point-min) (point-max)))))
215        nil t))
216      ;; Copy the URL to the kill ring.
217      (t
218       (with-temp-buffer
219         (insert url)
220         (copy-region-as-kill (point-min) (point-max))
221         (message "Copied %s" url))))))
222
223 (defun shr-next-link ()
224   "Skip to the next link."
225   (interactive)
226   (let ((skip (text-property-any (point) (point-max) 'help-echo nil)))
227     (if (not (setq skip (text-property-not-all skip (point-max)
228                                                'help-echo nil)))
229         (message "No next link")
230       (goto-char skip)
231       (message "%s" (get-text-property (point) 'help-echo)))))
232
233 (defun shr-previous-link ()
234   "Skip to the previous link."
235   (interactive)
236   (let ((start (point))
237         (found nil))
238     ;; Skip past the current link.
239     (while (and (not (bobp))
240                 (get-text-property (point) 'help-echo))
241       (forward-char -1))
242     ;; Find the previous link.
243     (while (and (not (bobp))
244                 (not (setq found (get-text-property (point) 'help-echo))))
245       (forward-char -1))
246     (if (not found)
247         (progn
248           (message "No previous link")
249           (goto-char start))
250       ;; Put point at the start of the link.
251       (while (and (not (bobp))
252                   (get-text-property (point) 'help-echo))
253         (forward-char -1))
254       (forward-char 1)
255       (message "%s" (get-text-property (point) 'help-echo)))))
256
257 (defun shr-show-alt-text ()
258   "Show the ALT text of the image under point."
259   (interactive)
260   (let ((text (get-text-property (point) 'shr-alt)))
261     (if (not text)
262         (message "No image under point")
263       (message "%s" text))))
264
265 (defun shr-browse-image (&optional copy-url)
266   "Browse the image under point.
267 If COPY-URL (the prefix if called interactively) is non-nil, copy
268 the URL of the image to the kill buffer instead."
269   (interactive "P")
270   (let ((url (get-text-property (point) 'image-url)))
271     (cond
272      ((not url)
273       (message "No image under point"))
274      (copy-url
275       (with-temp-buffer
276         (insert url)
277         (copy-region-as-kill (point-min) (point-max))
278         (message "Copied %s" url)))
279      (t
280       (message "Browsing %s..." url)
281       (browse-url url)))))
282
283 (defun shr-insert-image ()
284   "Insert the image under point into the buffer."
285   (interactive)
286   (let ((url (get-text-property (point) 'image-url)))
287     (if (not url)
288         (message "No image under point")
289       (message "Inserting %s..." url)
290       (url-retrieve url 'shr-image-fetched
291                     (list (current-buffer) (1- (point)) (point-marker))
292                     t t))))
293
294 (defun shr-zoom-image ()
295   "Toggle the image size.
296 The size will be rotated between the default size, the original
297 size, and full-buffer size."
298   (interactive)
299   (let ((url (get-text-property (point) 'image-url))
300         (size (get-text-property (point) 'image-size))
301         (buffer-read-only nil))
302     (if (not url)
303         (message "No image under point")
304       ;; Delete the old picture.
305       (while (get-text-property (point) 'image-url)
306         (forward-char -1))
307       (forward-char 1)
308       (let ((start (point)))
309         (while (get-text-property (point) 'image-url)
310           (forward-char 1))
311         (forward-char -1)
312         (put-text-property start (point) 'display nil)
313         (when (> (- (point) start) 2)
314           (delete-region start (1- (point)))))
315       (message "Inserting %s..." url)
316       (url-retrieve url 'shr-image-fetched
317                     (list (current-buffer) (1- (point)) (point-marker)
318                           (list (cons 'size
319                                       (cond ((or (eq size 'default)
320                                                  (null size))
321                                              'original)
322                                             ((eq size 'original)
323                                              'full)
324                                             ((eq size 'full)
325                                              'default)))))
326                     t))))
327
328 ;;; Utility functions.
329
330 (defun shr-transform-dom (dom)
331   (let ((result (list (pop dom))))
332     (dolist (arg (pop dom))
333       (push (cons (intern (concat ":" (symbol-name (car arg))) obarray)
334                   (cdr arg))
335             result))
336     (dolist (sub dom)
337       (if (stringp sub)
338           (push (cons 'text sub) result)
339         (push (shr-transform-dom sub) result)))
340     (nreverse result)))
341
342 (defun shr-descend (dom)
343   (let ((function
344          (or
345           ;; Allow other packages to override (or provide) rendering
346           ;; of elements.
347           (cdr (assq (car dom) shr-external-rendering-functions))
348           (intern (concat "shr-tag-" (symbol-name (car dom))) obarray)))
349         (style (cdr (assq :style (cdr dom))))
350         (shr-stylesheet shr-stylesheet)
351         (start (point)))
352     (when style
353       (if (string-match "color\\|display\\|border-collapse" style)
354           (setq shr-stylesheet (nconc (shr-parse-style style)
355                                       shr-stylesheet))
356         (setq style nil)))
357     ;; If we have a display:none, then just ignore this part of the
358     ;; DOM.
359     (unless (equal (cdr (assq 'display shr-stylesheet)) "none")
360       (if (fboundp function)
361           (funcall function (cdr dom))
362         (shr-generic (cdr dom)))
363       (when (and shr-target-id
364                  (equal (cdr (assq :id (cdr dom))) shr-target-id))
365         (put-text-property start (1+ start) 'shr-target-id shr-target-id))
366       ;; If style is set, then this node has set the color.
367       (when style
368         (shr-colorize-region start (point)
369                              (cdr (assq 'color shr-stylesheet))
370                              (cdr (assq 'background-color shr-stylesheet)))))))
371
372 (defun shr-generic (cont)
373   (dolist (sub cont)
374     (cond
375      ((eq (car sub) 'text)
376       (shr-insert (cdr sub)))
377      ((listp (cdr sub))
378       (shr-descend sub)))))
379
380 (defmacro shr-char-breakable-p (char)
381   "Return non-nil if a line can be broken before and after CHAR."
382   `(aref fill-find-break-point-function-table ,char))
383 (defmacro shr-char-nospace-p (char)
384   "Return non-nil if no space is required before and after CHAR."
385   `(aref fill-nospace-between-words-table ,char))
386
387 ;; KINSOKU is a Japanese word meaning a rule that should not be violated.
388 ;; In Emacs, it is a term used for characters, e.g. punctuation marks,
389 ;; parentheses, and so on, that should not be placed in the beginning
390 ;; of a line or the end of a line.
391 (defmacro shr-char-kinsoku-bol-p (char)
392   "Return non-nil if a line ought not to begin with CHAR."
393   `(aref (char-category-set ,char) ?>))
394 (defmacro shr-char-kinsoku-eol-p (char)
395   "Return non-nil if a line ought not to end with CHAR."
396   `(aref (char-category-set ,char) ?<))
397 (unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
398   (load "kinsoku" nil t))
399
400 (defun shr-insert (text)
401   (when (and (eq shr-state 'image)
402              (not (bolp))
403              (not (string-match "\\`[ \t\n]+\\'" text)))
404     (insert "\n")
405     (setq shr-state nil))
406   (cond
407    ((eq shr-folding-mode 'none)
408     (insert text))
409    (t
410     (when (and (string-match "\\`[ \t\n ]" text)
411                (not (bolp))
412                (not (eq (char-after (1- (point))) ? )))
413       (insert " "))
414     (dolist (elem (split-string text "[ \f\t\n\r\v ]+" t))
415       (when (and (bolp)
416                  (> shr-indentation 0))
417         (shr-indent))
418       ;; No space is needed behind a wide character categorized as
419       ;; kinsoku-bol, between characters both categorized as nospace,
420       ;; or at the beginning of a line.
421       (let (prev)
422         (when (and (> (current-column) shr-indentation)
423                    (eq (preceding-char) ? )
424                    (or (= (line-beginning-position) (1- (point)))
425                        (and (shr-char-breakable-p
426                              (setq prev (char-after (- (point) 2))))
427                             (shr-char-kinsoku-bol-p prev))
428                        (and (shr-char-nospace-p prev)
429                             (shr-char-nospace-p (aref elem 0)))))
430           (delete-char -1)))
431       ;; The shr-start is a special variable that is used to pass
432       ;; upwards the first point in the buffer where the text really
433       ;; starts.
434       (unless shr-start
435         (setq shr-start (point)))
436       (insert elem)
437       (setq shr-state nil)
438       (let (found)
439         (while (and (> (current-column) shr-width)
440                     (progn
441                       (setq found (shr-find-fill-point))
442                       (not (eolp))))
443           (when (eq (preceding-char) ? )
444             (delete-char -1))
445           (insert "\n")
446           (unless found
447             ;; No space is needed at the beginning of a line.
448             (when (eq (following-char) ? )
449               (delete-char 1)))
450           (when (> shr-indentation 0)
451             (shr-indent))
452           (end-of-line))
453         (insert " ")))
454     (unless (string-match "[ \t\r\n ]\\'" text)
455       (delete-char -1)))))
456
457 (defun shr-find-fill-point ()
458   (when (> (move-to-column shr-width) shr-width)
459     (backward-char 1))
460   (let ((bp (point))
461         failed)
462     (while (not (or (setq failed (= (current-column) shr-indentation))
463                     (eq (preceding-char) ? )
464                     (eq (following-char) ? )
465                     (shr-char-breakable-p (preceding-char))
466                     (shr-char-breakable-p (following-char))
467                     (if (eq (preceding-char) ?')
468                         (not (memq (char-after (- (point) 2))
469                                    (list nil ?\n ? )))
470                       (and (shr-char-kinsoku-bol-p (preceding-char))
471                            (shr-char-breakable-p (following-char))
472                            (not (shr-char-kinsoku-bol-p (following-char)))))
473                     (shr-char-kinsoku-eol-p (following-char))))
474       (backward-char 1))
475     (if (and (not (or failed (eolp)))
476              (eq (preceding-char) ?'))
477         (while (not (or (setq failed (eolp))
478                         (eq (following-char) ? )
479                         (shr-char-breakable-p (following-char))
480                         (shr-char-kinsoku-eol-p (following-char))))
481           (forward-char 1)))
482     (if failed
483         ;; There's no breakable point, so we give it up.
484         (let (found)
485           (goto-char bp)
486           (unless shr-kinsoku-shorten
487             (while (and (setq found (re-search-forward
488                                      "\\(\\c>\\)\\| \\|\\c<\\|\\c|"
489                                      (line-end-position) 'move))
490                         (eq (preceding-char) ?')))
491             (if (and found (not (match-beginning 1)))
492                 (goto-char (match-beginning 0)))))
493       (or
494        (eolp)
495        ;; Don't put kinsoku-bol characters at the beginning of a line,
496        ;; or kinsoku-eol characters at the end of a line.
497        (cond
498         (shr-kinsoku-shorten
499          (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
500                      (shr-char-kinsoku-eol-p (preceding-char)))
501            (backward-char 1))
502          (when (setq failed (= (current-column) shr-indentation))
503            ;; There's no breakable point that doesn't violate kinsoku,
504            ;; so we look for the second best position.
505            (while (and (progn
506                          (forward-char 1)
507                          (<= (current-column) shr-width))
508                        (progn
509                          (setq bp (point))
510                          (shr-char-kinsoku-eol-p (following-char)))))
511            (goto-char bp)))
512         ((shr-char-kinsoku-eol-p (preceding-char))
513          ;; Find backward the point where kinsoku-eol characters begin.
514          (let ((count 4))
515            (while
516                (progn
517                  (backward-char 1)
518                  (and (> (setq count (1- count)) 0)
519                       (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
520                       (or (shr-char-kinsoku-eol-p (preceding-char))
521                           (shr-char-kinsoku-bol-p (following-char)))))))
522          (if (setq failed (= (current-column) shr-indentation))
523              ;; There's no breakable point that doesn't violate kinsoku,
524              ;; so we go to the second best position.
525              (if (looking-at "\\(\\c<+\\)\\c<")
526                  (goto-char (match-end 1))
527                (forward-char 1))))
528         ((shr-char-kinsoku-bol-p (following-char))
529          ;; Find forward the point where kinsoku-bol characters end.
530          (let ((count 4))
531            (while (progn
532                     (forward-char 1)
533                     (and (>= (setq count (1- count)) 0)
534                          (shr-char-kinsoku-bol-p (following-char))
535                          (shr-char-breakable-p (following-char))))))))
536        (when (eq (following-char) ? )
537          (forward-char 1))))
538     (not failed)))
539
540 (defun shr-parse-base (url)
541   ;; Always chop off anchors.
542   (when (string-match "#.*" url)
543     (setq url (substring url 0 (match-beginning 0))))
544   (let* ((parsed (url-generic-parse-url url))
545          (local (url-filename parsed)))
546     (setf (url-filename parsed) "")
547     ;; Chop off the bit after the last slash.
548     (when (string-match "\\`\\(.*/\\)[^/]+\\'" local)
549       (setq local (match-string 1 local)))
550     ;; Always make the local bit end with a slash.
551     (when (and (not (zerop (length local)))
552                (not (eq (aref local (1- (length local))) ?/)))
553       (setq local (concat local "/")))
554     (list (url-recreate-url parsed)
555           local
556           (url-type parsed)
557           url)))
558
559 (defun shr-expand-url (url &optional base)
560   (setq base
561         (if base
562             (shr-parse-base base)
563           ;; Bound by the parser.
564           shr-base))
565   (when (zerop (length url))
566     (setq url nil))
567   (cond ((or (not url)
568              (not base)
569              (string-match "\\`[a-z]*:" url))
570          ;; Absolute URL.
571          (or url (car base)))
572         ((eq (aref url 0) ?/)
573          (if (and (> (length url) 1)
574                   (eq (aref url 1) ?/))
575              ;; //host...; just use the protocol
576              (concat (nth 2 base) ":" url)
577            ;; Just use the host name part.
578            (concat (car base) url)))
579         ((eq (aref url 0) ?#)
580          ;; A link to an anchor.
581          (concat (nth 3 base) url))
582         (t
583          ;; Totally relative.
584          (concat (car base) (cadr base) url))))
585
586 (defun shr-ensure-newline ()
587   (unless (zerop (current-column))
588     (insert "\n")))
589
590 (defun shr-ensure-paragraph ()
591   (unless (bobp)
592     (if (<= (current-column) shr-indentation)
593         (unless (save-excursion
594                   (forward-line -1)
595                   (looking-at " *$"))
596           (insert "\n"))
597       (if (save-excursion
598             (beginning-of-line)
599             (looking-at " *$"))
600           (delete-region (match-beginning 0) (match-end 0))
601         (insert "\n\n")))))
602
603 (defun shr-indent ()
604   (when (> shr-indentation 0)
605     (insert (make-string shr-indentation ? ))))
606
607 (defun shr-fontize-cont (cont &rest types)
608   (let (shr-start)
609     (shr-generic cont)
610     (dolist (type types)
611       (shr-add-font (or shr-start (point)) (point) type))))
612
613 ;; Add face to the region, but avoid putting the font properties on
614 ;; blank text at the start of the line, and the newline at the end, to
615 ;; avoid ugliness.
616 (defun shr-add-font (start end type)
617   (unless shr-inhibit-decoration
618     (save-excursion
619       (goto-char start)
620       (while (< (point) end)
621         (when (bolp)
622           (skip-chars-forward " "))
623         (add-face-text-property (point) (min (line-end-position) end) type t)
624         (if (< (line-end-position) end)
625             (forward-line 1)
626           (goto-char end))))))
627
628 (defun shr-browse-url ()
629   "Browse the URL under point."
630   (interactive)
631   (let ((url (get-text-property (point) 'shr-url)))
632     (cond
633      ((not url)
634       (message "No link under point"))
635      ((string-match "^mailto:" url)
636       (browse-url-mail url))
637      (t
638       (browse-url url)))))
639
640 (defun shr-save-contents (directory)
641   "Save the contents from URL in a file."
642   (interactive "DSave contents of URL to directory: ")
643   (let ((url (get-text-property (point) 'shr-url)))
644     (if (not url)
645         (message "No link under point")
646       (url-retrieve (shr-encode-url url)
647                     'shr-store-contents (list url directory)
648                     nil t))))
649
650 (defun shr-store-contents (status url directory)
651   (unless (plist-get status :error)
652     (when (or (search-forward "\n\n" nil t)
653               (search-forward "\r\n\r\n" nil t))
654       (write-region (point) (point-max)
655                     (expand-file-name (file-name-nondirectory url)
656                                       directory)))))
657
658 (defun shr-image-fetched (status buffer start end &optional flags)
659   (let ((image-buffer (current-buffer)))
660     (when (and (buffer-name buffer)
661                (not (plist-get status :error)))
662       (url-store-in-cache image-buffer)
663       (when (or (search-forward "\n\n" nil t)
664                 (search-forward "\r\n\r\n" nil t))
665         (let ((data (buffer-substring (point) (point-max))))
666           (with-current-buffer buffer
667             (save-excursion
668               (let ((alt (buffer-substring start end))
669                     (properties (text-properties-at start))
670                     (inhibit-read-only t))
671                 (delete-region start end)
672                 (goto-char start)
673                 (funcall shr-put-image-function data alt flags)
674                 (while properties
675                   (let ((type (pop properties))
676                         (value (pop properties)))
677                     (unless (memq type '(display image-size))
678                       (put-text-property start (point) type value))))))))))
679     (kill-buffer image-buffer)))
680
681 (defun shr-image-from-data (data)
682   "Return an image from the data: URI content DATA."
683   (when (string-match
684          "\\(\\([^/;,]+\\(/[^;,]+\\)?\\)\\(;[^;,]+\\)*\\)?,\\(.*\\)"
685          data)
686     (let ((param (match-string 4 data))
687           (payload (url-unhex-string (match-string 5 data))))
688       (when (string-match "^.*\\(;[ \t]*base64\\)$" param)
689         (setq payload (base64-decode-string payload)))
690       payload)))
691
692 (defun shr-put-image (data alt &optional flags)
693   "Put image DATA with a string ALT.  Return image."
694   (if (display-graphic-p)
695       (let* ((size (cdr (assq 'size flags)))
696              (start (point))
697              (image (cond
698                      ((eq size 'original)
699                       (create-image data nil t :ascent 100))
700                      ((eq size 'full)
701                       (ignore-errors
702                         (shr-rescale-image data t)))
703                      (t
704                       (ignore-errors
705                         (shr-rescale-image data))))))
706         (when image
707           ;; When inserting big-ish pictures, put them at the
708           ;; beginning of the line.
709           (when (and (> (current-column) 0)
710                      (> (car (image-size image t)) 400))
711             (insert "\n"))
712           (if (eq size 'original)
713               (insert-sliced-image image (or alt "*") nil 20 1)
714             (insert-image image (or alt "*")))
715           (put-text-property start (point) 'image-size size)
716           (when (cond ((fboundp 'image-multi-frame-p)
717                        ;; Only animate multi-frame things that specify a
718                        ;; delay; eg animated gifs as opposed to
719                        ;; multi-page tiffs.  FIXME?
720                        (cdr (image-multi-frame-p image)))
721                       ((fboundp 'image-animated-p)
722                        (image-animated-p image)))
723             (image-animate image nil 60)))
724         image)
725     (insert alt)))
726
727 (defun shr-rescale-image (data &optional force)
728   "Rescale DATA, if too big, to fit the current buffer.
729 If FORCE, rescale the image anyway."
730   (let ((image (create-image data nil t :ascent 100)))
731     (if (or (not (fboundp 'imagemagick-types))
732             (not (get-buffer-window (current-buffer))))
733         image
734       (let* ((size (image-size image t))
735              (width (car size))
736              (height (cdr size))
737              (edges (window-inside-pixel-edges
738                      (get-buffer-window (current-buffer))))
739              (window-width (truncate (* shr-max-image-proportion
740                                         (- (nth 2 edges) (nth 0 edges)))))
741              (window-height (truncate (* shr-max-image-proportion
742                                          (- (nth 3 edges) (nth 1 edges)))))
743              scaled-image)
744         (when (or force
745                   (> height window-height))
746           (setq image (or (create-image data 'imagemagick t
747                                         :height window-height
748                                         :ascent 100)
749                           image))
750           (setq size (image-size image t)))
751         (when (> (car size) window-width)
752           (setq image (or
753                        (create-image data 'imagemagick t
754                                      :width window-width
755                                      :ascent 100)
756                        image)))
757         image))))
758
759 ;; url-cache-extract autoloads url-cache.
760 (declare-function url-cache-create-filename "url-cache" (url))
761 (autoload 'mm-disable-multibyte "mm-util")
762 (autoload 'browse-url-mail "browse-url")
763
764 (defun shr-get-image-data (url)
765   "Get image data for URL.
766 Return a string with image data."
767   (with-temp-buffer
768     (mm-disable-multibyte)
769     (when (ignore-errors
770             (url-cache-extract (url-cache-create-filename (shr-encode-url url)))
771             t)
772       (when (or (search-forward "\n\n" nil t)
773                 (search-forward "\r\n\r\n" nil t))
774         (buffer-substring (point) (point-max))))))
775
776 (defun shr-image-displayer (content-function)
777   "Return a function to display an image.
778 CONTENT-FUNCTION is a function to retrieve an image for a cid url that
779 is an argument.  The function to be returned takes three arguments URL,
780 START, and END.  Note that START and END should be markers."
781   `(lambda (url start end)
782      (when url
783        (if (string-match "\\`cid:" url)
784            ,(when content-function
785               `(let ((image (funcall ,content-function
786                                      (substring url (match-end 0)))))
787                  (when image
788                    (goto-char start)
789                    (funcall shr-put-image-function
790                             image (buffer-substring start end))
791                    (delete-region (point) end))))
792          (url-retrieve url 'shr-image-fetched
793                        (list (current-buffer) start end)
794                        t t)))))
795
796 (defun shr-heading (cont &rest types)
797   (shr-ensure-paragraph)
798   (apply #'shr-fontize-cont cont types)
799   (shr-ensure-paragraph))
800
801 (defun shr-urlify (start url &optional title)
802   (when (and title (string-match "ctx" title)) (debug))
803   (shr-add-font start (point) 'shr-link)
804   (add-text-properties
805    start (point)
806    (list 'shr-url url
807          'help-echo (if title (format "%s (%s)" url title) url)
808          'local-map shr-map)))
809
810 (defun shr-encode-url (url)
811   "Encode URL."
812   (browse-url-url-encode-chars url "[)$ ]"))
813
814 (autoload 'shr-color-visible "shr-color")
815 (autoload 'shr-color->hexadecimal "shr-color")
816
817 (defun shr-color-check (fg bg)
818   "Check that FG is visible on BG.
819 Returns (fg bg) with corrected values.
820 Returns nil if the colors that would be used are the default
821 ones, in case fg and bg are nil."
822   (when (or fg bg)
823     (let ((fixed (cond ((null fg) 'fg)
824                        ((null bg) 'bg))))
825       ;; Convert colors to hexadecimal, or set them to default.
826       (let ((fg (or (shr-color->hexadecimal fg)
827                     (frame-parameter nil 'foreground-color)))
828             (bg (or (shr-color->hexadecimal bg)
829                     (frame-parameter nil 'background-color))))
830         (cond ((eq fixed 'bg)
831                ;; Only return the new fg
832                (list nil (cadr (shr-color-visible bg fg t))))
833               ((eq fixed 'fg)
834                ;; Invert args and results and return only the new bg
835                (list (cadr (shr-color-visible fg bg t)) nil))
836               (t
837                (shr-color-visible bg fg)))))))
838
839 (defun shr-colorize-region (start end fg &optional bg)
840   (when (and (not shr-inhibit-decoration)
841              (or fg bg))
842     (let ((new-colors (shr-color-check fg bg)))
843       (when new-colors
844         (when fg
845           (add-face-text-property start end
846                                   (list :foreground (cadr new-colors))
847                                   t))
848         (when bg
849           (add-face-text-property start end
850                                   (list :background (car new-colors))
851                                   t)))
852       new-colors)))
853
854 (defun shr-expand-newlines (start end color)
855   (save-restriction
856     ;; Skip past all white space at the start and ends.
857     (goto-char start)
858     (skip-chars-forward " \t\n")
859     (beginning-of-line)
860     (setq start (point))
861     (goto-char end)
862     (skip-chars-backward " \t\n")
863     (forward-line 1)
864     (setq end (point))
865     (narrow-to-region start end)
866     (let ((width (shr-buffer-width))
867           column)
868       (goto-char (point-min))
869       (while (not (eobp))
870         (end-of-line)
871         (when (and (< (setq column (current-column)) width)
872                    (< (setq column (shr-previous-newline-padding-width column))
873                       width))
874           (let ((overlay (make-overlay (point) (1+ (point)))))
875             (overlay-put overlay 'before-string
876                          (concat
877                           (mapconcat
878                            (lambda (overlay)
879                              (let ((string (plist-get
880                                             (overlay-properties overlay)
881                                             'before-string)))
882                                (if (not string)
883                                    ""
884                                  (overlay-put overlay 'before-string "")
885                                  string)))
886                            (overlays-at (point))
887                            "")
888                           (propertize (make-string (- width column) ? )
889                                       'face (list :background color))))))
890         (forward-line 1)))))
891
892 (defun shr-previous-newline-padding-width (width)
893   (let ((overlays (overlays-at (point)))
894         (previous-width 0))
895     (if (null overlays)
896         width
897       (dolist (overlay overlays)
898         (setq previous-width
899               (+ previous-width
900                  (length (plist-get (overlay-properties overlay)
901                                     'before-string)))))
902       (+ width previous-width))))
903
904 ;;; Tag-specific rendering rules.
905
906 (defun shr-tag-body (cont)
907   (let* ((start (point))
908          (fgcolor (cdr (or (assq :fgcolor cont)
909                            (assq :text cont))))
910          (bgcolor (cdr (assq :bgcolor cont)))
911          (shr-stylesheet (list (cons 'color fgcolor)
912                                (cons 'background-color bgcolor))))
913     (shr-generic cont)
914     (shr-colorize-region start (point) fgcolor bgcolor)))
915
916 (defun shr-tag-style (cont)
917   )
918
919 (defun shr-tag-script (cont)
920   )
921
922 (defun shr-tag-comment (cont)
923   )
924
925 (defun shr-dom-to-xml (dom)
926   "Convert DOM into a string containing the xml representation."
927   (let ((arg " ")
928         (text ""))
929     (dolist (sub (cdr dom))
930       (cond
931        ((listp (cdr sub))
932         (setq text (concat text (shr-dom-to-xml sub))))
933        ((eq (car sub) 'text)
934         (setq text (concat text (cdr sub))))
935        (t
936         (setq arg (concat arg (format "%s=\"%s\" "
937                                       (substring (symbol-name (car sub)) 1)
938                                       (cdr sub)))))))
939     (format "<%s%s>%s</%s>"
940             (car dom)
941             (substring arg 0 (1- (length arg)))
942             text
943             (car dom))))
944
945 (defun shr-tag-svg (cont)
946   (when (image-type-available-p 'svg)
947     (funcall shr-put-image-function
948              (shr-dom-to-xml (cons 'svg cont))
949              "SVG Image")))
950
951 (defun shr-tag-sup (cont)
952   (let ((start (point)))
953     (shr-generic cont)
954     (put-text-property start (point) 'display '(raise 0.5))))
955
956 (defun shr-tag-sub (cont)
957   (let ((start (point)))
958     (shr-generic cont)
959     (put-text-property start (point) 'display '(raise -0.5))))
960
961 (defun shr-tag-label (cont)
962   (shr-generic cont)
963   (shr-ensure-paragraph))
964
965 (defun shr-tag-p (cont)
966   (shr-ensure-paragraph)
967   (shr-indent)
968   (shr-generic cont)
969   (shr-ensure-paragraph))
970
971 (defun shr-tag-div (cont)
972   (shr-ensure-newline)
973   (shr-indent)
974   (shr-generic cont)
975   (shr-ensure-newline))
976
977 (defun shr-tag-s (cont)
978   (shr-fontize-cont cont 'shr-strike-through))
979
980 (defun shr-tag-del (cont)
981   (shr-fontize-cont cont 'shr-strike-through))
982
983 (defun shr-tag-b (cont)
984   (shr-fontize-cont cont 'bold))
985
986 (defun shr-tag-i (cont)
987   (shr-fontize-cont cont 'italic))
988
989 (defun shr-tag-em (cont)
990   (shr-fontize-cont cont 'italic))
991
992 (defun shr-tag-strong (cont)
993   (shr-fontize-cont cont 'bold))
994
995 (defun shr-tag-u (cont)
996   (shr-fontize-cont cont 'underline))
997
998 (defun shr-parse-style (style)
999   (when style
1000     (save-match-data
1001       (when (string-match "\n" style)
1002         (setq style (replace-match " " t t style))))
1003     (let ((plist nil))
1004       (dolist (elem (split-string style ";"))
1005         (when elem
1006           (setq elem (split-string elem ":"))
1007           (when (and (car elem)
1008                      (cadr elem))
1009             (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem)))
1010                   (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem))))
1011               (when (string-match " *!important\\'" value)
1012                 (setq value (substring value 0 (match-beginning 0))))
1013               (push (cons (intern name obarray)
1014                           value)
1015                     plist)))))
1016       plist)))
1017
1018 (defun shr-tag-base (cont)
1019   (let ((base (cdr (assq :href cont))))
1020     (when base
1021       (setq shr-base (shr-parse-base base))))
1022   (shr-generic cont))
1023
1024 (defun shr-tag-a (cont)
1025   (let ((url (cdr (assq :href cont)))
1026         (title (cdr (assq :title cont)))
1027         (start (point))
1028         shr-start)
1029     (shr-generic cont)
1030     (when (and url
1031                (not shr-inhibit-decoration))
1032       (shr-urlify (or shr-start start) (shr-expand-url url) title))))
1033
1034 (defun shr-tag-object (cont)
1035   (let ((start (point))
1036         url)
1037     (dolist (elem cont)
1038       (when (eq (car elem) 'embed)
1039         (setq url (or url (cdr (assq :src (cdr elem))))))
1040       (when (and (eq (car elem) 'param)
1041                  (equal (cdr (assq :name (cdr elem))) "movie"))
1042         (setq url (or url (cdr (assq :value (cdr elem)))))))
1043     (when url
1044       (shr-insert " [multimedia] ")
1045       (shr-urlify start (shr-expand-url url)))
1046     (shr-generic cont)))
1047
1048 (defun shr-tag-video (cont)
1049   (let ((image (cdr (assq :poster cont)))
1050         (url (cdr (assq :src cont)))
1051         (start (point)))
1052     (shr-tag-img nil image)
1053     (shr-urlify start (shr-expand-url url))))
1054
1055 (defun shr-tag-img (cont &optional url)
1056   (when (or url
1057             (and cont
1058                  (cdr (assq :src cont))))
1059     (when (and (> (current-column) 0)
1060                (not (eq shr-state 'image)))
1061       (insert "\n"))
1062     (let ((alt (cdr (assq :alt cont)))
1063           (url (shr-expand-url (or url (cdr (assq :src cont))))))
1064       (let ((start (point-marker)))
1065         (when (zerop (length alt))
1066           (setq alt "*"))
1067         (cond
1068          ((or (member (cdr (assq :height cont)) '("0" "1"))
1069               (member (cdr (assq :width cont)) '("0" "1")))
1070           ;; Ignore zero-sized or single-pixel images.
1071           )
1072          ((and (not shr-inhibit-images)
1073                (string-match "\\`data:" url))
1074           (let ((image (shr-image-from-data (substring url (match-end 0)))))
1075             (if image
1076                 (funcall shr-put-image-function image alt)
1077               (insert alt))))
1078          ((and (not shr-inhibit-images)
1079                (string-match "\\`cid:" url))
1080           (let ((url (substring url (match-end 0)))
1081                 image)
1082             (if (or (not shr-content-function)
1083                     (not (setq image (funcall shr-content-function url))))
1084                 (insert alt)
1085               (funcall shr-put-image-function image alt))))
1086          ((or shr-inhibit-images
1087               (and shr-blocked-images
1088                    (string-match shr-blocked-images url)))
1089           (setq shr-start (point))
1090           (let ((shr-state 'space))
1091             (if (> (string-width alt) 8)
1092                 (shr-insert (truncate-string-to-width alt 8))
1093               (shr-insert alt))))
1094          ((and (not shr-ignore-cache)
1095                (url-is-cached (shr-encode-url url)))
1096           (funcall shr-put-image-function (shr-get-image-data url) alt))
1097          (t
1098           (insert alt " ")
1099           (when (and shr-ignore-cache
1100                      (url-is-cached (shr-encode-url url)))
1101             (let ((file (url-cache-create-filename (shr-encode-url url))))
1102               (when (file-exists-p file)
1103                 (delete-file file))))
1104           (url-queue-retrieve
1105            (shr-encode-url url) 'shr-image-fetched
1106            (list (current-buffer) start (set-marker (make-marker) (1- (point))))
1107            t t)))
1108         (when (zerop shr-table-depth) ;; We are not in a table.
1109           (put-text-property start (point) 'keymap shr-map)
1110           (put-text-property start (point) 'shr-alt alt)
1111           (put-text-property start (point) 'image-url url)
1112           (put-text-property start (point) 'image-displayer
1113                              (shr-image-displayer shr-content-function))
1114           (put-text-property start (point) 'help-echo alt))
1115         (setq shr-state 'image)))))
1116
1117 (defun shr-tag-pre (cont)
1118   (let ((shr-folding-mode 'none))
1119     (shr-ensure-newline)
1120     (shr-indent)
1121     (shr-generic cont)
1122     (shr-ensure-newline)))
1123
1124 (defun shr-tag-blockquote (cont)
1125   (shr-ensure-paragraph)
1126   (shr-indent)
1127   (let ((shr-indentation (+ shr-indentation 4)))
1128     (shr-generic cont))
1129   (shr-ensure-paragraph))
1130
1131 (defun shr-tag-ul (cont)
1132   (shr-ensure-paragraph)
1133   (let ((shr-list-mode 'ul))
1134     (shr-generic cont))
1135   (shr-ensure-paragraph))
1136
1137 (defun shr-tag-ol (cont)
1138   (shr-ensure-paragraph)
1139   (let ((shr-list-mode 1))
1140     (shr-generic cont))
1141   (shr-ensure-paragraph))
1142
1143 (defun shr-tag-li (cont)
1144   (shr-ensure-newline)
1145   (shr-indent)
1146   (let* ((bullet
1147           (if (numberp shr-list-mode)
1148               (prog1
1149                   (format "%d " shr-list-mode)
1150                 (setq shr-list-mode (1+ shr-list-mode)))
1151             shr-bullet))
1152          (shr-indentation (+ shr-indentation (length bullet))))
1153     (insert bullet)
1154     (shr-generic cont)))
1155
1156 (defun shr-tag-br (cont)
1157   (when (and (not (bobp))
1158              ;; Only add a newline if we break the current line, or
1159              ;; the previous line isn't a blank line.
1160              (or (not (bolp))
1161                  (and (> (- (point) 2) (point-min))
1162                       (not (= (char-after (- (point) 2)) ?\n)))))
1163     (insert "\n")
1164     (shr-indent))
1165   (shr-generic cont))
1166
1167 (defun shr-tag-span (cont)
1168   (shr-generic cont))
1169
1170 (defun shr-tag-h1 (cont)
1171   (shr-heading cont 'bold 'underline))
1172
1173 (defun shr-tag-h2 (cont)
1174   (shr-heading cont 'bold))
1175
1176 (defun shr-tag-h3 (cont)
1177   (shr-heading cont 'italic))
1178
1179 (defun shr-tag-h4 (cont)
1180   (shr-heading cont))
1181
1182 (defun shr-tag-h5 (cont)
1183   (shr-heading cont))
1184
1185 (defun shr-tag-h6 (cont)
1186   (shr-heading cont))
1187
1188 (defun shr-tag-hr (cont)
1189   (shr-ensure-newline)
1190   (insert (make-string shr-width shr-hr-line) "\n"))
1191
1192 (defun shr-tag-title (cont)
1193   (shr-heading cont 'bold 'underline))
1194
1195 (defun shr-tag-font (cont)
1196   (let* ((start (point))
1197          (color (cdr (assq :color cont)))
1198          (shr-stylesheet (nconc (list (cons 'color color))
1199                                 shr-stylesheet)))
1200     (shr-generic cont)
1201     (when color
1202       (shr-colorize-region start (point) color
1203                            (cdr (assq 'background-color shr-stylesheet))))))
1204
1205 ;;; Table rendering algorithm.
1206
1207 ;; Table rendering is the only complicated thing here.  We do this by
1208 ;; first counting how many TDs there are in each TR, and registering
1209 ;; how wide they think they should be ("width=45%", etc).  Then we
1210 ;; render each TD separately (this is done in temporary buffers, so
1211 ;; that we can use all the rendering machinery as if we were in the
1212 ;; main buffer).  Now we know how much space each TD really takes, so
1213 ;; we then render everything again with the new widths, and finally
1214 ;; insert all these boxes into the main buffer.
1215 (defun shr-tag-table-1 (cont)
1216   (setq cont (or (cdr (assq 'tbody cont))
1217                  cont))
1218   (let* ((shr-inhibit-images t)
1219          (shr-table-depth (1+ shr-table-depth))
1220          (shr-kinsoku-shorten t)
1221          ;; Find all suggested widths.
1222          (columns (shr-column-specs cont))
1223          ;; Compute how many characters wide each TD should be.
1224          (suggested-widths (shr-pro-rate-columns columns))
1225          ;; Do a "test rendering" to see how big each TD is (this can
1226          ;; be smaller (if there's little text) or bigger (if there's
1227          ;; unbreakable text).
1228          (sketch (shr-make-table cont suggested-widths))
1229          ;; Compute the "natural" width by setting each column to 500
1230          ;; characters and see how wide they really render.
1231          (natural (shr-make-table cont (make-vector (length columns) 500)))
1232          (sketch-widths (shr-table-widths sketch natural suggested-widths)))
1233     ;; This probably won't work very well.
1234     (when (> (+ (loop for width across sketch-widths
1235                       summing (1+ width))
1236                 shr-indentation 1)
1237              (frame-width))
1238       (setq truncate-lines t))
1239     ;; Then render the table again with these new "hard" widths.
1240     (shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths))
1241   ;; Finally, insert all the images after the table.  The Emacs buffer
1242   ;; model isn't strong enough to allow us to put the images actually
1243   ;; into the tables.
1244   (when (zerop shr-table-depth)
1245     (dolist (elem (shr-find-elements cont 'img))
1246       (shr-tag-img (cdr elem)))))
1247
1248 (defun shr-tag-table (cont)
1249   (shr-ensure-paragraph)
1250   (let* ((caption (cdr (assq 'caption cont)))
1251          (header (cdr (assq 'thead cont)))
1252          (body (or (cdr (assq 'tbody cont)) cont))
1253          (footer (cdr (assq 'tfoot cont)))
1254          (bgcolor (cdr (assq :bgcolor cont)))
1255          (start (point))
1256          (shr-stylesheet (nconc (list (cons 'background-color bgcolor))
1257                                 shr-stylesheet))
1258          (nheader (if header (shr-max-columns header)))
1259          (nbody (if body (shr-max-columns body)))
1260          (nfooter (if footer (shr-max-columns footer))))
1261     (if (and (not caption)
1262              (not header)
1263              (not (cdr (assq 'tbody cont)))
1264              (not (cdr (assq 'tr cont)))
1265              (not footer))
1266         ;; The table is totally invalid and just contains random junk.
1267         ;; Try to output it anyway.
1268         (shr-generic cont)
1269       ;; It's a real table, so render it.
1270       (shr-tag-table-1
1271        (nconc
1272         (if caption `((tr (td ,@caption))))
1273         (if header
1274             (if footer
1275                 ;; hader + body + footer
1276                 (if (= nheader nbody)
1277                     (if (= nbody nfooter)
1278                         `((tr (td (table (tbody ,@header ,@body ,@footer)))))
1279                       (nconc `((tr (td (table (tbody ,@header ,@body)))))
1280                              (if (= nfooter 1)
1281                                  footer
1282                                `((tr (td (table (tbody ,@footer))))))))
1283                   (nconc `((tr (td (table (tbody ,@header)))))
1284                          (if (= nbody nfooter)
1285                              `((tr (td (table (tbody ,@body ,@footer)))))
1286                            (nconc `((tr (td (table (tbody ,@body)))))
1287                                   (if (= nfooter 1)
1288                                       footer
1289                                     `((tr (td (table (tbody ,@footer))))))))))
1290               ;; header + body
1291               (if (= nheader nbody)
1292                   `((tr (td (table (tbody ,@header ,@body)))))
1293                 (if (= nheader 1)
1294                     `(,@header (tr (td (table (tbody ,@body)))))
1295                   `((tr (td (table (tbody ,@header))))
1296                     (tr (td (table (tbody ,@body))))))))
1297           (if footer
1298               ;; body + footer
1299               (if (= nbody nfooter)
1300                   `((tr (td (table (tbody ,@body ,@footer)))))
1301                 (nconc `((tr (td (table (tbody ,@body)))))
1302                        (if (= nfooter 1)
1303                            footer
1304                          `((tr (td (table (tbody ,@footer))))))))
1305             (if caption
1306                 `((tr (td (table (tbody ,@body)))))
1307               body))))))
1308     (when bgcolor
1309       (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
1310                            bgcolor))))
1311
1312 (defun shr-find-elements (cont type)
1313   (let (result)
1314     (dolist (elem cont)
1315       (cond ((eq (car elem) type)
1316              (push elem result))
1317             ((consp (cdr elem))
1318              (setq result (nconc (shr-find-elements (cdr elem) type) result)))))
1319     (nreverse result)))
1320
1321 (defun shr-insert-table (table widths)
1322   (let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet))
1323                           "collapse"))
1324          (shr-table-vertical-line (if collapse "" shr-table-vertical-line)))
1325     (unless collapse
1326       (shr-insert-table-ruler widths))
1327     (dolist (row table)
1328       (let ((start (point))
1329             (height (let ((max 0))
1330                       (dolist (column row)
1331                         (setq max (max max (cadr column))))
1332                       max)))
1333         (dotimes (i height)
1334           (shr-indent)
1335           (insert shr-table-vertical-line "\n"))
1336         (dolist (column row)
1337           (goto-char start)
1338           (let ((lines (nth 2 column)))
1339             (dolist (line lines)
1340               (end-of-line)
1341               (insert line shr-table-vertical-line)
1342               (forward-line 1))
1343             ;; Add blank lines at padding at the bottom of the TD,
1344             ;; possibly.
1345             (dotimes (i (- height (length lines)))
1346               (end-of-line)
1347               (let ((start (point)))
1348                 (insert (make-string (string-width (car lines)) ? )
1349                         shr-table-vertical-line)
1350                 (when (nth 4 column)
1351                   (shr-add-font start (1- (point))
1352                                 (list :background (nth 4 column)))))
1353               (forward-line 1)))))
1354       (unless collapse
1355         (shr-insert-table-ruler widths)))))
1356
1357 (defun shr-insert-table-ruler (widths)
1358   (when (and (bolp)
1359              (> shr-indentation 0))
1360     (shr-indent))
1361   (insert shr-table-corner)
1362   (dotimes (i (length widths))
1363     (insert (make-string (aref widths i) shr-table-horizontal-line)
1364             shr-table-corner))
1365   (insert "\n"))
1366
1367 (defun shr-table-widths (table natural-table suggested-widths)
1368   (let* ((length (length suggested-widths))
1369          (widths (make-vector length 0))
1370          (natural-widths (make-vector length 0)))
1371     (dolist (row table)
1372       (let ((i 0))
1373         (dolist (column row)
1374           (aset widths i (max (aref widths i) column))
1375           (setq i (1+ i)))))
1376     (dolist (row natural-table)
1377       (let ((i 0))
1378         (dolist (column row)
1379           (aset natural-widths i (max (aref natural-widths i) column))
1380           (setq i (1+ i)))))
1381     (let ((extra (- (apply '+ (append suggested-widths nil))
1382                     (apply '+ (append widths nil))))
1383           (expanded-columns 0))
1384       ;; We have extra, unused space, so divide this space amongst the
1385       ;; columns.
1386       (when (> extra 0)
1387         ;; If the natural width is wider than the rendered width, we
1388         ;; want to allow the column to expand.
1389         (dotimes (i length)
1390           (when (> (aref natural-widths i) (aref widths i))
1391             (setq expanded-columns (1+ expanded-columns))))
1392         (dotimes (i length)
1393           (when (> (aref natural-widths i) (aref widths i))
1394             (aset widths i (min
1395                             (aref natural-widths i)
1396                             (+ (/ extra expanded-columns)
1397                                (aref widths i))))))))
1398     widths))
1399
1400 (defun shr-make-table (cont widths &optional fill)
1401   (or (cadr (assoc (list cont widths fill) shr-content-cache))
1402       (let ((data (shr-make-table-1 cont widths fill)))
1403         (push (list (list cont widths fill) data)
1404               shr-content-cache)
1405         data)))
1406
1407 (defun shr-make-table-1 (cont widths &optional fill)
1408   (let ((trs nil)
1409         (shr-inhibit-decoration (not fill)))
1410     (dolist (row cont)
1411       (when (eq (car row) 'tr)
1412         (let ((tds nil)
1413               (columns (cdr row))
1414               (i 0)
1415               column)
1416           (while (< i (length widths))
1417             (setq column (pop columns))
1418             (when (or (memq (car column) '(td th))
1419                       (null column))
1420               (push (shr-render-td (cdr column) (aref widths i) fill)
1421                     tds)
1422               (setq i (1+ i))))
1423           (push (nreverse tds) trs))))
1424     (nreverse trs)))
1425
1426 (defun shr-render-td (cont width fill)
1427   (with-temp-buffer
1428     (let ((bgcolor (cdr (assq :bgcolor cont)))
1429           (fgcolor (cdr (assq :fgcolor cont)))
1430           (style (cdr (assq :style cont)))
1431           (shr-stylesheet shr-stylesheet)
1432           actual-colors)
1433       (when style
1434         (setq style (and (string-match "color" style)
1435                          (shr-parse-style style))))
1436       (when bgcolor
1437         (setq style (nconc (list (cons 'background-color bgcolor)) style)))
1438       (when fgcolor
1439         (setq style (nconc (list (cons 'color fgcolor)) style)))
1440       (when style
1441         (setq shr-stylesheet (append style shr-stylesheet)))
1442       (let ((shr-width width)
1443             (shr-indentation 0))
1444         (shr-descend (cons 'td cont)))
1445       ;; Delete padding at the bottom of the TDs.
1446       (delete-region
1447        (point)
1448        (progn
1449          (skip-chars-backward " \t\n")
1450          (end-of-line)
1451          (point)))
1452       (goto-char (point-min))
1453       (let ((max 0))
1454         (while (not (eobp))
1455           (end-of-line)
1456           (setq max (max max (current-column)))
1457           (forward-line 1))
1458         (when fill
1459           (goto-char (point-min))
1460           ;; If the buffer is totally empty, then put a single blank
1461           ;; line here.
1462           (if (zerop (buffer-size))
1463               (insert (make-string width ? ))
1464             ;; Otherwise, fill the buffer.
1465             (let ((align (cdr (assq :align cont)))
1466                   length)
1467               (while (not (eobp))
1468                 (end-of-line)
1469                 (setq length (- width (current-column)))
1470                 (when (> length 0)
1471                   (cond
1472                    ((equal align "right")
1473                     (beginning-of-line)
1474                     (insert (make-string length ? )))
1475                    ((equal align "center")
1476                     (insert (make-string (/ length 2) ? ))
1477                     (beginning-of-line)
1478                     (insert (make-string (- length (/ length 2)) ? )))
1479                    (t
1480                     (insert (make-string length ? )))))
1481                 (forward-line 1))))
1482           (when style
1483             (setq actual-colors
1484                   (shr-colorize-region
1485                    (point-min) (point-max)
1486                    (cdr (assq 'color shr-stylesheet))
1487                    (cdr (assq 'background-color shr-stylesheet))))))
1488         (if fill
1489             (list max
1490                   (count-lines (point-min) (point-max))
1491                   (split-string (buffer-string) "\n")
1492                   nil
1493                   (car actual-colors))
1494           max)))))
1495
1496 (defun shr-buffer-width ()
1497   (goto-char (point-min))
1498   (let ((max 0))
1499     (while (not (eobp))
1500       (end-of-line)
1501       (setq max (max max (current-column)))
1502       (forward-line 1))
1503     max))
1504
1505 (defun shr-pro-rate-columns (columns)
1506   (let ((total-percentage 0)
1507         (widths (make-vector (length columns) 0)))
1508     (dotimes (i (length columns))
1509       (setq total-percentage (+ total-percentage (aref columns i))))
1510     (setq total-percentage (/ 1.0 total-percentage))
1511     (dotimes (i (length columns))
1512       (aset widths i (max (truncate (* (aref columns i)
1513                                        total-percentage
1514                                        (- shr-width (1+ (length columns)))))
1515                           10)))
1516     widths))
1517
1518 ;; Return a summary of the number and shape of the TDs in the table.
1519 (defun shr-column-specs (cont)
1520   (let ((columns (make-vector (shr-max-columns cont) 1)))
1521     (dolist (row cont)
1522       (when (eq (car row) 'tr)
1523         (let ((i 0))
1524           (dolist (column (cdr row))
1525             (when (memq (car column) '(td th))
1526               (let ((width (cdr (assq :width (cdr column)))))
1527                 (when (and width
1528                            (string-match "\\([0-9]+\\)%" width)
1529                            (not (zerop (setq width (string-to-number
1530                                                     (match-string 1 width))))))
1531                   (aset columns i (/ width 100.0))))
1532               (setq i (1+ i)))))))
1533     columns))
1534
1535 (defun shr-count (cont elem)
1536   (let ((i 0))
1537     (dolist (sub cont)
1538       (when (eq (car sub) elem)
1539         (setq i (1+ i))))
1540     i))
1541
1542 (defun shr-max-columns (cont)
1543   (let ((max 0))
1544     (dolist (row cont)
1545       (when (eq (car row) 'tr)
1546         (setq max (max max (+ (shr-count (cdr row) 'td)
1547                               (shr-count (cdr row) 'th))))))
1548     max))
1549
1550 ;; Emacs less than 24.3
1551 (unless (fboundp 'add-face-text-property)
1552   (defun add-face-text-property (beg end face &optional appendp object)
1553     "Combine FACE BEG and END."
1554     (let ((b beg))
1555       (while (< b end)
1556         (let ((oldval (get-text-property b 'face)))
1557           (put-text-property
1558            b (setq b (next-single-property-change b 'face nil end))
1559            'face (cond ((null oldval)
1560                         face)
1561                        ((and (consp oldval)
1562                              (not (keywordp (car oldval))))
1563                         (if appendp
1564                             (nconc oldval (list face))
1565                           (cons face oldval)))
1566                        (t
1567                         (if appendp
1568                             (list oldval face)
1569                           (list face oldval))))))))))
1570
1571 (provide 'shr)
1572
1573 ;; Local Variables:
1574 ;; coding: utf-8
1575 ;; End:
1576
1577 ;;; shr.el ends here