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