shr.el 43 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397
  1. ;;; shr.el --- Simple HTML Renderer
  2. ;; Copyright (C) 2010-2012 Free Software Foundation, Inc.
  3. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
  4. ;; Keywords: html
  5. ;; This file is part of GNU Emacs.
  6. ;; GNU Emacs is free software: you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation, either version 3 of the License, or
  9. ;; (at your option) any later version.
  10. ;; GNU Emacs is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  13. ;; GNU General Public License for more details.
  14. ;; You should have received a copy of the GNU General Public License
  15. ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
  16. ;;; Commentary:
  17. ;; This package takes a HTML parse tree (as provided by
  18. ;; libxml-parse-html-region) and renders it in the current buffer. It
  19. ;; does not do CSS, JavaScript or anything advanced: It's geared
  20. ;; towards rendering typical short snippets of HTML, like what you'd
  21. ;; find in HTML email and the like.
  22. ;;; Code:
  23. (eval-when-compile (require 'cl))
  24. (require 'browse-url)
  25. (defgroup shr nil
  26. "Simple HTML Renderer"
  27. :version "24.1"
  28. :group 'mail)
  29. (defcustom shr-max-image-proportion 0.9
  30. "How big pictures displayed are in relation to the window they're in.
  31. A value of 0.7 means that they are allowed to take up 70% of the
  32. width and height of the window. If they are larger than this,
  33. and Emacs supports it, then the images will be rescaled down to
  34. fit these criteria."
  35. :version "24.1"
  36. :group 'shr
  37. :type 'float)
  38. (defcustom shr-blocked-images nil
  39. "Images that have URLs matching this regexp will be blocked."
  40. :version "24.1"
  41. :group 'shr
  42. :type 'regexp)
  43. (defcustom shr-table-horizontal-line ?\s
  44. "Character used to draw horizontal table lines."
  45. :group 'shr
  46. :type 'character)
  47. (defcustom shr-table-vertical-line ?\s
  48. "Character used to draw vertical table lines."
  49. :group 'shr
  50. :type 'character)
  51. (defcustom shr-table-corner ?\s
  52. "Character used to draw table corners."
  53. :group 'shr
  54. :type 'character)
  55. (defcustom shr-hr-line ?-
  56. "Character used to draw hr lines."
  57. :group 'shr
  58. :type 'character)
  59. (defcustom shr-width fill-column
  60. "Frame width to use for rendering.
  61. May either be an integer specifying a fixed width in characters,
  62. or nil, meaning that the full width of the window should be
  63. used."
  64. :type '(choice (integer :tag "Fixed width in characters")
  65. (const :tag "Use the width of the window" nil))
  66. :group 'shr)
  67. (defvar shr-content-function nil
  68. "If bound, this should be a function that will return the content.
  69. This is used for cid: URLs, and the function is called with the
  70. cid: URL as the argument.")
  71. (defvar shr-put-image-function 'shr-put-image
  72. "Function called to put image and alt string.")
  73. (defface shr-strike-through '((t (:strike-through t)))
  74. "Font for <s> elements."
  75. :group 'shr)
  76. (defface shr-link
  77. '((t (:inherit link)))
  78. "Font for link elements."
  79. :group 'shr)
  80. ;;; Internal variables.
  81. (defvar shr-folding-mode nil)
  82. (defvar shr-state nil)
  83. (defvar shr-start nil)
  84. (defvar shr-indentation 0)
  85. (defvar shr-inhibit-images nil)
  86. (defvar shr-list-mode nil)
  87. (defvar shr-content-cache nil)
  88. (defvar shr-kinsoku-shorten nil)
  89. (defvar shr-table-depth 0)
  90. (defvar shr-stylesheet nil)
  91. (defvar shr-base nil)
  92. (defvar shr-ignore-cache nil)
  93. (defvar shr-map
  94. (let ((map (make-sparse-keymap)))
  95. (define-key map "a" 'shr-show-alt-text)
  96. (define-key map "i" 'shr-browse-image)
  97. (define-key map "I" 'shr-insert-image)
  98. (define-key map "u" 'shr-copy-url)
  99. (define-key map "v" 'shr-browse-url)
  100. (define-key map "o" 'shr-save-contents)
  101. (define-key map "\r" 'shr-browse-url)
  102. map))
  103. ;; Public functions and commands.
  104. (defun shr-visit-file (file)
  105. "Parse FILE as an HTML document, and render it in a new buffer."
  106. (interactive "fHTML file name: ")
  107. (pop-to-buffer "*html*")
  108. (erase-buffer)
  109. (shr-insert-document
  110. (with-temp-buffer
  111. (insert-file-contents file)
  112. (libxml-parse-html-region (point-min) (point-max))))
  113. (goto-char (point-min)))
  114. ;;;###autoload
  115. (defun shr-insert-document (dom)
  116. "Render the parsed document DOM into the current buffer.
  117. DOM should be a parse tree as generated by
  118. `libxml-parse-html-region' or similar."
  119. (setq shr-content-cache nil)
  120. (let ((start (point))
  121. (shr-state nil)
  122. (shr-start nil)
  123. (shr-base nil)
  124. (shr-width (or shr-width (window-width))))
  125. (shr-descend (shr-transform-dom dom))
  126. (shr-remove-trailing-whitespace start (point))))
  127. (defun shr-remove-trailing-whitespace (start end)
  128. (let ((width (window-width)))
  129. (save-restriction
  130. (narrow-to-region start end)
  131. (goto-char start)
  132. (while (not (eobp))
  133. (end-of-line)
  134. (when (> (shr-previous-newline-padding-width (current-column)) width)
  135. (dolist (overlay (overlays-at (point)))
  136. (when (overlay-get overlay 'before-string)
  137. (overlay-put overlay 'before-string nil))))
  138. (forward-line 1)))))
  139. (defun shr-copy-url ()
  140. "Copy the URL under point to the kill ring.
  141. If called twice, then try to fetch the URL and see whether it
  142. redirects somewhere else."
  143. (interactive)
  144. (let ((url (get-text-property (point) 'shr-url)))
  145. (cond
  146. ((not url)
  147. (message "No URL under point"))
  148. ;; Resolve redirected URLs.
  149. ((equal url (car kill-ring))
  150. (url-retrieve
  151. url
  152. (lambda (a)
  153. (when (and (consp a)
  154. (eq (car a) :redirect))
  155. (with-temp-buffer
  156. (insert (cadr a))
  157. (goto-char (point-min))
  158. ;; Remove common tracking junk from the URL.
  159. (when (re-search-forward ".utm_.*" nil t)
  160. (replace-match "" t t))
  161. (message "Copied %s" (buffer-string))
  162. (copy-region-as-kill (point-min) (point-max)))))
  163. nil t))
  164. ;; Copy the URL to the kill ring.
  165. (t
  166. (with-temp-buffer
  167. (insert url)
  168. (copy-region-as-kill (point-min) (point-max))
  169. (message "Copied %s" url))))))
  170. (defun shr-show-alt-text ()
  171. "Show the ALT text of the image under point."
  172. (interactive)
  173. (let ((text (get-text-property (point) 'shr-alt)))
  174. (if (not text)
  175. (message "No image under point")
  176. (message "%s" text))))
  177. (defun shr-browse-image (&optional copy-url)
  178. "Browse the image under point.
  179. If COPY-URL (the prefix if called interactively) is non-nil, copy
  180. the URL of the image to the kill buffer instead."
  181. (interactive "P")
  182. (let ((url (get-text-property (point) 'image-url)))
  183. (cond
  184. ((not url)
  185. (message "No image under point"))
  186. (copy-url
  187. (with-temp-buffer
  188. (insert url)
  189. (copy-region-as-kill (point-min) (point-max))
  190. (message "Copied %s" url)))
  191. (t
  192. (message "Browsing %s..." url)
  193. (browse-url url)))))
  194. (defun shr-insert-image ()
  195. "Insert the image under point into the buffer."
  196. (interactive)
  197. (let ((url (get-text-property (point) 'image-url)))
  198. (if (not url)
  199. (message "No image under point")
  200. (message "Inserting %s..." url)
  201. (url-retrieve url 'shr-image-fetched
  202. (list (current-buffer) (1- (point)) (point-marker))
  203. t t))))
  204. ;;; Utility functions.
  205. (defun shr-transform-dom (dom)
  206. (let ((result (list (pop dom))))
  207. (dolist (arg (pop dom))
  208. (push (cons (intern (concat ":" (symbol-name (car arg))) obarray)
  209. (cdr arg))
  210. result))
  211. (dolist (sub dom)
  212. (if (stringp sub)
  213. (push (cons 'text sub) result)
  214. (push (shr-transform-dom sub) result)))
  215. (nreverse result)))
  216. (defun shr-descend (dom)
  217. (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))
  218. (style (cdr (assq :style (cdr dom))))
  219. (shr-stylesheet shr-stylesheet)
  220. (start (point)))
  221. (when style
  222. (if (string-match "color" style)
  223. (setq shr-stylesheet (nconc (shr-parse-style style)
  224. shr-stylesheet))
  225. (setq style nil)))
  226. (if (fboundp function)
  227. (funcall function (cdr dom))
  228. (shr-generic (cdr dom)))
  229. ;; If style is set, then this node has set the color.
  230. (when style
  231. (shr-colorize-region start (point)
  232. (cdr (assq 'color shr-stylesheet))
  233. (cdr (assq 'background-color shr-stylesheet))))))
  234. (defun shr-generic (cont)
  235. (dolist (sub cont)
  236. (cond
  237. ((eq (car sub) 'text)
  238. (shr-insert (cdr sub)))
  239. ((listp (cdr sub))
  240. (shr-descend sub)))))
  241. (defmacro shr-char-breakable-p (char)
  242. "Return non-nil if a line can be broken before and after CHAR."
  243. `(aref fill-find-break-point-function-table ,char))
  244. (defmacro shr-char-nospace-p (char)
  245. "Return non-nil if no space is required before and after CHAR."
  246. `(aref fill-nospace-between-words-table ,char))
  247. ;; KINSOKU is a Japanese word meaning a rule that should not be violated.
  248. ;; In Emacs, it is a term used for characters, e.g. punctuation marks,
  249. ;; parentheses, and so on, that should not be placed in the beginning
  250. ;; of a line or the end of a line.
  251. (defmacro shr-char-kinsoku-bol-p (char)
  252. "Return non-nil if a line ought not to begin with CHAR."
  253. `(aref (char-category-set ,char) ?>))
  254. (defmacro shr-char-kinsoku-eol-p (char)
  255. "Return non-nil if a line ought not to end with CHAR."
  256. `(aref (char-category-set ,char) ?<))
  257. (unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
  258. (load "kinsoku" nil t))
  259. (defun shr-insert (text)
  260. (when (and (eq shr-state 'image)
  261. (not (string-match "\\`[ \t\n]+\\'" text)))
  262. (insert "\n")
  263. (setq shr-state nil))
  264. (cond
  265. ((eq shr-folding-mode 'none)
  266. (insert text))
  267. (t
  268. (when (and (string-match "\\`[ \t\n]" text)
  269. (not (bolp))
  270. (not (eq (char-after (1- (point))) ? )))
  271. (insert " "))
  272. (dolist (elem (split-string text))
  273. (when (and (bolp)
  274. (> shr-indentation 0))
  275. (shr-indent))
  276. ;; No space is needed behind a wide character categorized as
  277. ;; kinsoku-bol, between characters both categorized as nospace,
  278. ;; or at the beginning of a line.
  279. (let (prev)
  280. (when (and (> (current-column) shr-indentation)
  281. (eq (preceding-char) ? )
  282. (or (= (line-beginning-position) (1- (point)))
  283. (and (shr-char-breakable-p
  284. (setq prev (char-after (- (point) 2))))
  285. (shr-char-kinsoku-bol-p prev))
  286. (and (shr-char-nospace-p prev)
  287. (shr-char-nospace-p (aref elem 0)))))
  288. (delete-char -1)))
  289. ;; The shr-start is a special variable that is used to pass
  290. ;; upwards the first point in the buffer where the text really
  291. ;; starts.
  292. (unless shr-start
  293. (setq shr-start (point)))
  294. (insert elem)
  295. (setq shr-state nil)
  296. (let (found)
  297. (while (and (> (current-column) shr-width)
  298. (progn
  299. (setq found (shr-find-fill-point))
  300. (not (eolp))))
  301. (when (eq (preceding-char) ? )
  302. (delete-char -1))
  303. (insert "\n")
  304. (unless found
  305. ;; No space is needed at the beginning of a line.
  306. (when (eq (following-char) ? )
  307. (delete-char 1)))
  308. (when (> shr-indentation 0)
  309. (shr-indent))
  310. (end-of-line))
  311. (insert " ")))
  312. (unless (string-match "[ \t\n]\\'" text)
  313. (delete-char -1)))))
  314. (defun shr-find-fill-point ()
  315. (when (> (move-to-column shr-width) shr-width)
  316. (backward-char 1))
  317. (let ((bp (point))
  318. failed)
  319. (while (not (or (setq failed (= (current-column) shr-indentation))
  320. (eq (preceding-char) ? )
  321. (eq (following-char) ? )
  322. (shr-char-breakable-p (preceding-char))
  323. (shr-char-breakable-p (following-char))
  324. (if (eq (preceding-char) ?')
  325. (not (memq (char-after (- (point) 2))
  326. (list nil ?\n ? )))
  327. (and (shr-char-kinsoku-bol-p (preceding-char))
  328. (shr-char-breakable-p (following-char))
  329. (not (shr-char-kinsoku-bol-p (following-char)))))
  330. (shr-char-kinsoku-eol-p (following-char))))
  331. (backward-char 1))
  332. (if (and (not (or failed (eolp)))
  333. (eq (preceding-char) ?'))
  334. (while (not (or (setq failed (eolp))
  335. (eq (following-char) ? )
  336. (shr-char-breakable-p (following-char))
  337. (shr-char-kinsoku-eol-p (following-char))))
  338. (forward-char 1)))
  339. (if failed
  340. ;; There's no breakable point, so we give it up.
  341. (let (found)
  342. (goto-char bp)
  343. (unless shr-kinsoku-shorten
  344. (while (and (setq found (re-search-forward
  345. "\\(\\c>\\)\\| \\|\\c<\\|\\c|"
  346. (line-end-position) 'move))
  347. (eq (preceding-char) ?')))
  348. (if (and found (not (match-beginning 1)))
  349. (goto-char (match-beginning 0)))))
  350. (or
  351. (eolp)
  352. ;; Don't put kinsoku-bol characters at the beginning of a line,
  353. ;; or kinsoku-eol characters at the end of a line.
  354. (cond
  355. (shr-kinsoku-shorten
  356. (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
  357. (shr-char-kinsoku-eol-p (preceding-char)))
  358. (backward-char 1))
  359. (when (setq failed (= (current-column) shr-indentation))
  360. ;; There's no breakable point that doesn't violate kinsoku,
  361. ;; so we look for the second best position.
  362. (while (and (progn
  363. (forward-char 1)
  364. (<= (current-column) shr-width))
  365. (progn
  366. (setq bp (point))
  367. (shr-char-kinsoku-eol-p (following-char)))))
  368. (goto-char bp)))
  369. ((shr-char-kinsoku-eol-p (preceding-char))
  370. (if (shr-char-kinsoku-eol-p (following-char))
  371. ;; There are consecutive kinsoku-eol characters.
  372. (setq failed t)
  373. (let ((count 4))
  374. (while
  375. (progn
  376. (backward-char 1)
  377. (and (> (setq count (1- count)) 0)
  378. (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
  379. (or (shr-char-kinsoku-eol-p (preceding-char))
  380. (shr-char-kinsoku-bol-p (following-char)))))))
  381. (if (setq failed (= (current-column) shr-indentation))
  382. ;; There's no breakable point that doesn't violate kinsoku,
  383. ;; so we go to the second best position.
  384. (if (looking-at "\\(\\c<+\\)\\c<")
  385. (goto-char (match-end 1))
  386. (forward-char 1)))))
  387. (t
  388. (if (shr-char-kinsoku-bol-p (preceding-char))
  389. ;; There are consecutive kinsoku-bol characters.
  390. (setq failed t)
  391. (let ((count 4))
  392. (while (and (>= (setq count (1- count)) 0)
  393. (shr-char-kinsoku-bol-p (following-char))
  394. (shr-char-breakable-p (following-char)))
  395. (forward-char 1))))))
  396. (when (eq (following-char) ? )
  397. (forward-char 1))))
  398. (not failed)))
  399. (defun shr-expand-url (url)
  400. (cond
  401. ;; Absolute URL.
  402. ((or (not url)
  403. (string-match "\\`[a-z]*:" url)
  404. (not shr-base))
  405. url)
  406. ((and (not (string-match "/\\'" shr-base))
  407. (not (string-match "\\`/" url)))
  408. (concat shr-base "/" url))
  409. (t
  410. (concat shr-base url))))
  411. (defun shr-ensure-newline ()
  412. (unless (zerop (current-column))
  413. (insert "\n")))
  414. (defun shr-ensure-paragraph ()
  415. (unless (bobp)
  416. (if (<= (current-column) shr-indentation)
  417. (unless (save-excursion
  418. (forward-line -1)
  419. (looking-at " *$"))
  420. (insert "\n"))
  421. (if (save-excursion
  422. (beginning-of-line)
  423. (looking-at " *$"))
  424. (insert "\n")
  425. (insert "\n\n")))))
  426. (defun shr-indent ()
  427. (when (> shr-indentation 0)
  428. (insert (make-string shr-indentation ? ))))
  429. (defun shr-fontize-cont (cont &rest types)
  430. (let (shr-start)
  431. (shr-generic cont)
  432. (dolist (type types)
  433. (shr-add-font (or shr-start (point)) (point) type))))
  434. ;; Add an overlay in the region, but avoid putting the font properties
  435. ;; on blank text at the start of the line, and the newline at the end,
  436. ;; to avoid ugliness.
  437. (defun shr-add-font (start end type)
  438. (save-excursion
  439. (goto-char start)
  440. (while (< (point) end)
  441. (when (bolp)
  442. (skip-chars-forward " "))
  443. (let ((overlay (make-overlay (point) (min (line-end-position) end))))
  444. (overlay-put overlay 'face type))
  445. (if (< (line-end-position) end)
  446. (forward-line 1)
  447. (goto-char end)))))
  448. (defun shr-browse-url ()
  449. "Browse the URL under point."
  450. (interactive)
  451. (let ((url (get-text-property (point) 'shr-url)))
  452. (cond
  453. ((not url)
  454. (message "No link under point"))
  455. ((string-match "^mailto:" url)
  456. (browse-url-mail url))
  457. (t
  458. (browse-url url)))))
  459. (defun shr-save-contents (directory)
  460. "Save the contents from URL in a file."
  461. (interactive "DSave contents of URL to directory: ")
  462. (let ((url (get-text-property (point) 'shr-url)))
  463. (if (not url)
  464. (message "No link under point")
  465. (url-retrieve (shr-encode-url url)
  466. 'shr-store-contents (list url directory)
  467. nil t))))
  468. (defun shr-store-contents (status url directory)
  469. (unless (plist-get status :error)
  470. (when (or (search-forward "\n\n" nil t)
  471. (search-forward "\r\n\r\n" nil t))
  472. (write-region (point) (point-max)
  473. (expand-file-name (file-name-nondirectory url)
  474. directory)))))
  475. (defun shr-image-fetched (status buffer start end)
  476. (let ((image-buffer (current-buffer)))
  477. (when (and (buffer-name buffer)
  478. (not (plist-get status :error)))
  479. (url-store-in-cache image-buffer)
  480. (when (or (search-forward "\n\n" nil t)
  481. (search-forward "\r\n\r\n" nil t))
  482. (let ((data (buffer-substring (point) (point-max))))
  483. (with-current-buffer buffer
  484. (save-excursion
  485. (let ((alt (buffer-substring start end))
  486. (inhibit-read-only t))
  487. (delete-region start end)
  488. (goto-char start)
  489. (funcall shr-put-image-function data alt)))))))
  490. (kill-buffer image-buffer)))
  491. (defun shr-put-image (data alt)
  492. "Put image DATA with a string ALT. Return image."
  493. (if (display-graphic-p)
  494. (let ((image (ignore-errors
  495. (shr-rescale-image data))))
  496. (when image
  497. ;; When inserting big-ish pictures, put them at the
  498. ;; beginning of the line.
  499. (when (and (> (current-column) 0)
  500. (> (car (image-size image t)) 400))
  501. (insert "\n"))
  502. (insert-image image (or alt "*"))
  503. (when (image-animated-p image)
  504. (image-animate image nil 60)))
  505. image)
  506. (insert alt)))
  507. (defun shr-rescale-image (data)
  508. (let ((image (create-image data nil t :ascent 100)))
  509. (if (or (not (fboundp 'imagemagick-types))
  510. (not (get-buffer-window (current-buffer))))
  511. image
  512. (let* ((size (image-size image t))
  513. (width (car size))
  514. (height (cdr size))
  515. (edges (window-inside-pixel-edges
  516. (get-buffer-window (current-buffer))))
  517. (window-width (truncate (* shr-max-image-proportion
  518. (- (nth 2 edges) (nth 0 edges)))))
  519. (window-height (truncate (* shr-max-image-proportion
  520. (- (nth 3 edges) (nth 1 edges)))))
  521. scaled-image)
  522. (when (> height window-height)
  523. (setq image (or (create-image data 'imagemagick t
  524. :height window-height
  525. :ascent 100)
  526. image))
  527. (setq size (image-size image t)))
  528. (when (> (car size) window-width)
  529. (setq image (or
  530. (create-image data 'imagemagick t
  531. :width window-width
  532. :ascent 100)
  533. image)))
  534. image))))
  535. ;; url-cache-extract autoloads url-cache.
  536. (declare-function url-cache-create-filename "url-cache" (url))
  537. (autoload 'mm-disable-multibyte "mm-util")
  538. (autoload 'browse-url-mail "browse-url")
  539. (defun shr-get-image-data (url)
  540. "Get image data for URL.
  541. Return a string with image data."
  542. (with-temp-buffer
  543. (mm-disable-multibyte)
  544. (when (ignore-errors
  545. (url-cache-extract (url-cache-create-filename (shr-encode-url url)))
  546. t)
  547. (when (or (search-forward "\n\n" nil t)
  548. (search-forward "\r\n\r\n" nil t))
  549. (buffer-substring (point) (point-max))))))
  550. (defun shr-image-displayer (content-function)
  551. "Return a function to display an image.
  552. CONTENT-FUNCTION is a function to retrieve an image for a cid url that
  553. is an argument. The function to be returned takes three arguments URL,
  554. START, and END. Note that START and END should be markers."
  555. `(lambda (url start end)
  556. (when url
  557. (if (string-match "\\`cid:" url)
  558. ,(when content-function
  559. `(let ((image (funcall ,content-function
  560. (substring url (match-end 0)))))
  561. (when image
  562. (goto-char start)
  563. (funcall shr-put-image-function
  564. image (buffer-substring start end))
  565. (delete-region (point) end))))
  566. (url-retrieve url 'shr-image-fetched
  567. (list (current-buffer) start end)
  568. t t)))))
  569. (defun shr-heading (cont &rest types)
  570. (shr-ensure-paragraph)
  571. (apply #'shr-fontize-cont cont types)
  572. (shr-ensure-paragraph))
  573. (autoload 'widget-convert-button "wid-edit")
  574. (defun shr-urlify (start url &optional title)
  575. (widget-convert-button
  576. 'url-link start (point)
  577. :help-echo (if title (format "%s (%s)" url title) url)
  578. :keymap shr-map
  579. url)
  580. (shr-add-font start (point) 'shr-link)
  581. (put-text-property start (point) 'shr-url url))
  582. (defun shr-encode-url (url)
  583. "Encode URL."
  584. (browse-url-url-encode-chars url "[)$ ]"))
  585. (autoload 'shr-color-visible "shr-color")
  586. (autoload 'shr-color->hexadecimal "shr-color")
  587. (defun shr-color-check (fg bg)
  588. "Check that FG is visible on BG.
  589. Returns (fg bg) with corrected values.
  590. Returns nil if the colors that would be used are the default
  591. ones, in case fg and bg are nil."
  592. (when (or fg bg)
  593. (let ((fixed (cond ((null fg) 'fg)
  594. ((null bg) 'bg))))
  595. ;; Convert colors to hexadecimal, or set them to default.
  596. (let ((fg (or (shr-color->hexadecimal fg)
  597. (frame-parameter nil 'foreground-color)))
  598. (bg (or (shr-color->hexadecimal bg)
  599. (frame-parameter nil 'background-color))))
  600. (cond ((eq fixed 'bg)
  601. ;; Only return the new fg
  602. (list nil (cadr (shr-color-visible bg fg t))))
  603. ((eq fixed 'fg)
  604. ;; Invert args and results and return only the new bg
  605. (list (cadr (shr-color-visible fg bg t)) nil))
  606. (t
  607. (shr-color-visible bg fg)))))))
  608. (defun shr-colorize-region (start end fg &optional bg)
  609. (when (or fg bg)
  610. (let ((new-colors (shr-color-check fg bg)))
  611. (when new-colors
  612. (when fg
  613. (shr-put-color start end :foreground (cadr new-colors)))
  614. (when bg
  615. (shr-put-color start end :background (car new-colors))))
  616. new-colors)))
  617. ;; Put a color in the region, but avoid putting colors on blank
  618. ;; text at the start of the line, and the newline at the end, to avoid
  619. ;; ugliness. Also, don't overwrite any existing color information,
  620. ;; since this can be called recursively, and we want the "inner" color
  621. ;; to win.
  622. (defun shr-put-color (start end type color)
  623. (save-excursion
  624. (goto-char start)
  625. (while (< (point) end)
  626. (when (and (bolp)
  627. (not (eq type :background)))
  628. (skip-chars-forward " "))
  629. (when (> (line-end-position) (point))
  630. (shr-put-color-1 (point) (min (line-end-position) end) type color))
  631. (if (< (line-end-position) end)
  632. (forward-line 1)
  633. (goto-char end)))
  634. (when (and (eq type :background)
  635. (= shr-table-depth 0))
  636. (shr-expand-newlines start end color))))
  637. (defun shr-expand-newlines (start end color)
  638. (save-restriction
  639. ;; Skip past all white space at the start and ends.
  640. (goto-char start)
  641. (skip-chars-forward " \t\n")
  642. (beginning-of-line)
  643. (setq start (point))
  644. (goto-char end)
  645. (skip-chars-backward " \t\n")
  646. (forward-line 1)
  647. (setq end (point))
  648. (narrow-to-region start end)
  649. (let ((width (shr-buffer-width))
  650. column)
  651. (goto-char (point-min))
  652. (while (not (eobp))
  653. (end-of-line)
  654. (when (and (< (setq column (current-column)) width)
  655. (< (setq column (shr-previous-newline-padding-width column))
  656. width))
  657. (let ((overlay (make-overlay (point) (1+ (point)))))
  658. (overlay-put overlay 'before-string
  659. (concat
  660. (mapconcat
  661. (lambda (overlay)
  662. (let ((string (plist-get
  663. (overlay-properties overlay)
  664. 'before-string)))
  665. (if (not string)
  666. ""
  667. (overlay-put overlay 'before-string "")
  668. string)))
  669. (overlays-at (point))
  670. "")
  671. (propertize (make-string (- width column) ? )
  672. 'face (list :background color))))))
  673. (forward-line 1)))))
  674. (defun shr-previous-newline-padding-width (width)
  675. (let ((overlays (overlays-at (point)))
  676. (previous-width 0))
  677. (if (null overlays)
  678. width
  679. (dolist (overlay overlays)
  680. (setq previous-width
  681. (+ previous-width
  682. (length (plist-get (overlay-properties overlay)
  683. 'before-string)))))
  684. (+ width previous-width))))
  685. (defun shr-put-color-1 (start end type color)
  686. (let* ((old-props (get-text-property start 'face))
  687. (do-put (and (listp old-props)
  688. (not (memq type old-props))))
  689. change)
  690. (while (< start end)
  691. (setq change (next-single-property-change start 'face nil end))
  692. (when do-put
  693. (put-text-property start change 'face
  694. (nconc (list type color) old-props)))
  695. (setq old-props (get-text-property change 'face))
  696. (setq do-put (and (listp old-props)
  697. (not (memq type old-props))))
  698. (setq start change))
  699. (when (and do-put
  700. (> end start))
  701. (put-text-property start end 'face
  702. (nconc (list type color old-props))))))
  703. ;;; Tag-specific rendering rules.
  704. (defun shr-tag-body (cont)
  705. (let* ((start (point))
  706. (fgcolor (cdr (or (assq :fgcolor cont)
  707. (assq :text cont))))
  708. (bgcolor (cdr (assq :bgcolor cont)))
  709. (shr-stylesheet (list (cons 'color fgcolor)
  710. (cons 'background-color bgcolor))))
  711. (shr-generic cont)
  712. (shr-colorize-region start (point) fgcolor bgcolor)))
  713. (defun shr-tag-style (cont)
  714. )
  715. (defun shr-tag-script (cont)
  716. )
  717. (defun shr-tag-comment (cont)
  718. )
  719. (defun shr-tag-sup (cont)
  720. (let ((start (point)))
  721. (shr-generic cont)
  722. (put-text-property start (point) 'display '(raise 0.5))))
  723. (defun shr-tag-sub (cont)
  724. (let ((start (point)))
  725. (shr-generic cont)
  726. (put-text-property start (point) 'display '(raise -0.5))))
  727. (defun shr-tag-label (cont)
  728. (shr-generic cont)
  729. (shr-ensure-paragraph))
  730. (defun shr-tag-p (cont)
  731. (shr-ensure-paragraph)
  732. (shr-indent)
  733. (shr-generic cont)
  734. (shr-ensure-paragraph))
  735. (defun shr-tag-div (cont)
  736. (shr-ensure-newline)
  737. (shr-indent)
  738. (shr-generic cont)
  739. (shr-ensure-newline))
  740. (defun shr-tag-s (cont)
  741. (shr-fontize-cont cont 'shr-strike-through))
  742. (defun shr-tag-del (cont)
  743. (shr-fontize-cont cont 'shr-strike-through))
  744. (defun shr-tag-b (cont)
  745. (shr-fontize-cont cont 'bold))
  746. (defun shr-tag-i (cont)
  747. (shr-fontize-cont cont 'italic))
  748. (defun shr-tag-em (cont)
  749. (shr-fontize-cont cont 'bold))
  750. (defun shr-tag-strong (cont)
  751. (shr-fontize-cont cont 'bold))
  752. (defun shr-tag-u (cont)
  753. (shr-fontize-cont cont 'underline))
  754. (defun shr-parse-style (style)
  755. (when style
  756. (save-match-data
  757. (when (string-match "\n" style)
  758. (setq style (replace-match " " t t style))))
  759. (let ((plist nil))
  760. (dolist (elem (split-string style ";"))
  761. (when elem
  762. (setq elem (split-string elem ":"))
  763. (when (and (car elem)
  764. (cadr elem))
  765. (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem)))
  766. (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem))))
  767. (when (string-match " *!important\\'" value)
  768. (setq value (substring value 0 (match-beginning 0))))
  769. (push (cons (intern name obarray)
  770. value)
  771. plist)))))
  772. plist)))
  773. (defun shr-tag-base (cont)
  774. (setq shr-base (cdr (assq :href cont))))
  775. (defun shr-tag-a (cont)
  776. (let ((url (cdr (assq :href cont)))
  777. (title (cdr (assq :title cont)))
  778. (start (point))
  779. shr-start)
  780. (shr-generic cont)
  781. (shr-urlify (or shr-start start) (shr-expand-url url) title)))
  782. (defun shr-tag-object (cont)
  783. (let ((start (point))
  784. url)
  785. (dolist (elem cont)
  786. (when (eq (car elem) 'embed)
  787. (setq url (or url (cdr (assq :src (cdr elem))))))
  788. (when (and (eq (car elem) 'param)
  789. (equal (cdr (assq :name (cdr elem))) "movie"))
  790. (setq url (or url (cdr (assq :value (cdr elem)))))))
  791. (when url
  792. (shr-insert " [multimedia] ")
  793. (shr-urlify start (shr-expand-url url)))
  794. (shr-generic cont)))
  795. (defun shr-tag-video (cont)
  796. (let ((image (cdr (assq :poster cont)))
  797. (url (cdr (assq :src cont)))
  798. (start (point)))
  799. (shr-tag-img nil image)
  800. (shr-urlify start (shr-expand-url url))))
  801. (defun shr-tag-img (cont &optional url)
  802. (when (or url
  803. (and cont
  804. (cdr (assq :src cont))))
  805. (when (and (> (current-column) 0)
  806. (not (eq shr-state 'image)))
  807. (insert "\n"))
  808. (let ((alt (cdr (assq :alt cont)))
  809. (url (shr-expand-url (or url (cdr (assq :src cont))))))
  810. (let ((start (point-marker)))
  811. (when (zerop (length alt))
  812. (setq alt "*"))
  813. (cond
  814. ((or (member (cdr (assq :height cont)) '("0" "1"))
  815. (member (cdr (assq :width cont)) '("0" "1")))
  816. ;; Ignore zero-sized or single-pixel images.
  817. )
  818. ((and (not shr-inhibit-images)
  819. (string-match "\\`cid:" url))
  820. (let ((url (substring url (match-end 0)))
  821. image)
  822. (if (or (not shr-content-function)
  823. (not (setq image (funcall shr-content-function url))))
  824. (insert alt)
  825. (funcall shr-put-image-function image alt))))
  826. ((or shr-inhibit-images
  827. (and shr-blocked-images
  828. (string-match shr-blocked-images url)))
  829. (setq shr-start (point))
  830. (let ((shr-state 'space))
  831. (if (> (string-width alt) 8)
  832. (shr-insert (truncate-string-to-width alt 8))
  833. (shr-insert alt))))
  834. ((and (not shr-ignore-cache)
  835. (url-is-cached (shr-encode-url url)))
  836. (funcall shr-put-image-function (shr-get-image-data url) alt))
  837. (t
  838. (insert alt " ")
  839. (when (and shr-ignore-cache
  840. (url-is-cached (shr-encode-url url)))
  841. (let ((file (url-cache-create-filename (shr-encode-url url))))
  842. (when (file-exists-p file)
  843. (delete-file file))))
  844. (url-queue-retrieve
  845. (shr-encode-url url) 'shr-image-fetched
  846. (list (current-buffer) start (set-marker (make-marker) (1- (point))))
  847. t t)))
  848. (when (zerop shr-table-depth) ;; We are not in a table.
  849. (put-text-property start (point) 'keymap shr-map)
  850. (put-text-property start (point) 'shr-alt alt)
  851. (put-text-property start (point) 'image-url url)
  852. (put-text-property start (point) 'image-displayer
  853. (shr-image-displayer shr-content-function))
  854. (put-text-property start (point) 'help-echo alt))
  855. (setq shr-state 'image)))))
  856. (defun shr-tag-pre (cont)
  857. (let ((shr-folding-mode 'none))
  858. (shr-ensure-newline)
  859. (shr-indent)
  860. (shr-generic cont)
  861. (shr-ensure-newline)))
  862. (defun shr-tag-blockquote (cont)
  863. (shr-ensure-paragraph)
  864. (shr-indent)
  865. (let ((shr-indentation (+ shr-indentation 4)))
  866. (shr-generic cont))
  867. (shr-ensure-paragraph))
  868. (defun shr-tag-ul (cont)
  869. (shr-ensure-paragraph)
  870. (let ((shr-list-mode 'ul))
  871. (shr-generic cont))
  872. (shr-ensure-paragraph))
  873. (defun shr-tag-ol (cont)
  874. (shr-ensure-paragraph)
  875. (let ((shr-list-mode 1))
  876. (shr-generic cont))
  877. (shr-ensure-paragraph))
  878. (defun shr-tag-li (cont)
  879. (shr-ensure-paragraph)
  880. (shr-indent)
  881. (let* ((bullet
  882. (if (numberp shr-list-mode)
  883. (prog1
  884. (format "%d " shr-list-mode)
  885. (setq shr-list-mode (1+ shr-list-mode)))
  886. "* "))
  887. (shr-indentation (+ shr-indentation (length bullet))))
  888. (insert bullet)
  889. (shr-generic cont)))
  890. (defun shr-tag-br (cont)
  891. (unless (bobp)
  892. (insert "\n")
  893. (shr-indent))
  894. (shr-generic cont))
  895. (defun shr-tag-h1 (cont)
  896. (shr-heading cont 'bold 'underline))
  897. (defun shr-tag-h2 (cont)
  898. (shr-heading cont 'bold))
  899. (defun shr-tag-h3 (cont)
  900. (shr-heading cont 'italic))
  901. (defun shr-tag-h4 (cont)
  902. (shr-heading cont))
  903. (defun shr-tag-h5 (cont)
  904. (shr-heading cont))
  905. (defun shr-tag-h6 (cont)
  906. (shr-heading cont))
  907. (defun shr-tag-hr (cont)
  908. (shr-ensure-newline)
  909. (insert (make-string shr-width shr-hr-line) "\n"))
  910. (defun shr-tag-title (cont)
  911. (shr-heading cont 'bold 'underline))
  912. (defun shr-tag-font (cont)
  913. (let* ((start (point))
  914. (color (cdr (assq :color cont)))
  915. (shr-stylesheet (nconc (list (cons 'color color))
  916. shr-stylesheet)))
  917. (shr-generic cont)
  918. (when color
  919. (shr-colorize-region start (point) color
  920. (cdr (assq 'background-color shr-stylesheet))))))
  921. ;;; Table rendering algorithm.
  922. ;; Table rendering is the only complicated thing here. We do this by
  923. ;; first counting how many TDs there are in each TR, and registering
  924. ;; how wide they think they should be ("width=45%", etc). Then we
  925. ;; render each TD separately (this is done in temporary buffers, so
  926. ;; that we can use all the rendering machinery as if we were in the
  927. ;; main buffer). Now we know how much space each TD really takes, so
  928. ;; we then render everything again with the new widths, and finally
  929. ;; insert all these boxes into the main buffer.
  930. (defun shr-tag-table-1 (cont)
  931. (setq cont (or (cdr (assq 'tbody cont))
  932. cont))
  933. (let* ((shr-inhibit-images t)
  934. (shr-table-depth (1+ shr-table-depth))
  935. (shr-kinsoku-shorten t)
  936. ;; Find all suggested widths.
  937. (columns (shr-column-specs cont))
  938. ;; Compute how many characters wide each TD should be.
  939. (suggested-widths (shr-pro-rate-columns columns))
  940. ;; Do a "test rendering" to see how big each TD is (this can
  941. ;; be smaller (if there's little text) or bigger (if there's
  942. ;; unbreakable text).
  943. (sketch (shr-make-table cont suggested-widths))
  944. ;; Compute the "natural" width by setting each column to 500
  945. ;; characters and see how wide they really render.
  946. (natural (shr-make-table cont (make-vector (length columns) 500)))
  947. (sketch-widths (shr-table-widths sketch natural suggested-widths)))
  948. ;; This probably won't work very well.
  949. (when (> (+ (loop for width across sketch-widths
  950. summing (1+ width))
  951. shr-indentation 1)
  952. (frame-width))
  953. (setq truncate-lines t))
  954. ;; Then render the table again with these new "hard" widths.
  955. (shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths))
  956. ;; Finally, insert all the images after the table. The Emacs buffer
  957. ;; model isn't strong enough to allow us to put the images actually
  958. ;; into the tables.
  959. (when (zerop shr-table-depth)
  960. (dolist (elem (shr-find-elements cont 'img))
  961. (shr-tag-img (cdr elem)))))
  962. (defun shr-tag-table (cont)
  963. (shr-ensure-paragraph)
  964. (let* ((caption (cdr (assq 'caption cont)))
  965. (header (cdr (assq 'thead cont)))
  966. (body (or (cdr (assq 'tbody cont)) cont))
  967. (footer (cdr (assq 'tfoot cont)))
  968. (bgcolor (cdr (assq :bgcolor cont)))
  969. (start (point))
  970. (shr-stylesheet (nconc (list (cons 'background-color bgcolor))
  971. shr-stylesheet))
  972. (nheader (if header (shr-max-columns header)))
  973. (nbody (if body (shr-max-columns body)))
  974. (nfooter (if footer (shr-max-columns footer))))
  975. (if (and (not caption)
  976. (not header)
  977. (not (cdr (assq 'tbody cont)))
  978. (not (cdr (assq 'tr cont)))
  979. (not footer))
  980. ;; The table is totally invalid and just contains random junk.
  981. ;; Try to output it anyway.
  982. (shr-generic cont)
  983. ;; It's a real table, so render it.
  984. (shr-tag-table-1
  985. (nconc
  986. (if caption `((tr (td ,@caption))))
  987. (if header
  988. (if footer
  989. ;; hader + body + footer
  990. (if (= nheader nbody)
  991. (if (= nbody nfooter)
  992. `((tr (td (table (tbody ,@header ,@body ,@footer)))))
  993. (nconc `((tr (td (table (tbody ,@header ,@body)))))
  994. (if (= nfooter 1)
  995. footer
  996. `((tr (td (table (tbody ,@footer))))))))
  997. (nconc `((tr (td (table (tbody ,@header)))))
  998. (if (= nbody nfooter)
  999. `((tr (td (table (tbody ,@body ,@footer)))))
  1000. (nconc `((tr (td (table (tbody ,@body)))))
  1001. (if (= nfooter 1)
  1002. footer
  1003. `((tr (td (table (tbody ,@footer))))))))))
  1004. ;; header + body
  1005. (if (= nheader nbody)
  1006. `((tr (td (table (tbody ,@header ,@body)))))
  1007. (if (= nheader 1)
  1008. `(,@header (tr (td (table (tbody ,@body)))))
  1009. `((tr (td (table (tbody ,@header))))
  1010. (tr (td (table (tbody ,@body))))))))
  1011. (if footer
  1012. ;; body + footer
  1013. (if (= nbody nfooter)
  1014. `((tr (td (table (tbody ,@body ,@footer)))))
  1015. (nconc `((tr (td (table (tbody ,@body)))))
  1016. (if (= nfooter 1)
  1017. footer
  1018. `((tr (td (table (tbody ,@footer))))))))
  1019. (if caption
  1020. `((tr (td (table (tbody ,@body)))))
  1021. body))))))
  1022. (when bgcolor
  1023. (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
  1024. bgcolor))))
  1025. (defun shr-find-elements (cont type)
  1026. (let (result)
  1027. (dolist (elem cont)
  1028. (cond ((eq (car elem) type)
  1029. (push elem result))
  1030. ((consp (cdr elem))
  1031. (setq result (nconc (shr-find-elements (cdr elem) type) result)))))
  1032. (nreverse result)))
  1033. (defun shr-insert-table (table widths)
  1034. (shr-insert-table-ruler widths)
  1035. (dolist (row table)
  1036. (let ((start (point))
  1037. (height (let ((max 0))
  1038. (dolist (column row)
  1039. (setq max (max max (cadr column))))
  1040. max)))
  1041. (dotimes (i height)
  1042. (shr-indent)
  1043. (insert shr-table-vertical-line "\n"))
  1044. (dolist (column row)
  1045. (goto-char start)
  1046. (let ((lines (nth 2 column))
  1047. (overlay-lines (nth 3 column))
  1048. overlay overlay-line)
  1049. (dolist (line lines)
  1050. (setq overlay-line (pop overlay-lines))
  1051. (end-of-line)
  1052. (insert line shr-table-vertical-line)
  1053. (dolist (overlay overlay-line)
  1054. (let ((o (make-overlay (- (point) (nth 0 overlay) 1)
  1055. (- (point) (nth 1 overlay) 1)))
  1056. (properties (nth 2 overlay)))
  1057. (while properties
  1058. (overlay-put o (pop properties) (pop properties)))))
  1059. (forward-line 1))
  1060. ;; Add blank lines at padding at the bottom of the TD,
  1061. ;; possibly.
  1062. (dotimes (i (- height (length lines)))
  1063. (end-of-line)
  1064. (let ((start (point)))
  1065. (insert (make-string (string-width (car lines)) ? )
  1066. shr-table-vertical-line)
  1067. (when (nth 4 column)
  1068. (shr-put-color start (1- (point)) :background (nth 4 column))))
  1069. (forward-line 1)))))
  1070. (shr-insert-table-ruler widths)))
  1071. (defun shr-insert-table-ruler (widths)
  1072. (when (and (bolp)
  1073. (> shr-indentation 0))
  1074. (shr-indent))
  1075. (insert shr-table-corner)
  1076. (dotimes (i (length widths))
  1077. (insert (make-string (aref widths i) shr-table-horizontal-line)
  1078. shr-table-corner))
  1079. (insert "\n"))
  1080. (defun shr-table-widths (table natural-table suggested-widths)
  1081. (let* ((length (length suggested-widths))
  1082. (widths (make-vector length 0))
  1083. (natural-widths (make-vector length 0)))
  1084. (dolist (row table)
  1085. (let ((i 0))
  1086. (dolist (column row)
  1087. (aset widths i (max (aref widths i) column))
  1088. (setq i (1+ i)))))
  1089. (dolist (row natural-table)
  1090. (let ((i 0))
  1091. (dolist (column row)
  1092. (aset natural-widths i (max (aref natural-widths i) column))
  1093. (setq i (1+ i)))))
  1094. (let ((extra (- (apply '+ (append suggested-widths nil))
  1095. (apply '+ (append widths nil))))
  1096. (expanded-columns 0))
  1097. ;; We have extra, unused space, so divide this space amongst the
  1098. ;; columns.
  1099. (when (> extra 0)
  1100. ;; If the natural width is wider than the rendered width, we
  1101. ;; want to allow the column to expand.
  1102. (dotimes (i length)
  1103. (when (> (aref natural-widths i) (aref widths i))
  1104. (setq expanded-columns (1+ expanded-columns))))
  1105. (dotimes (i length)
  1106. (when (> (aref natural-widths i) (aref widths i))
  1107. (aset widths i (min
  1108. (aref natural-widths i)
  1109. (+ (/ extra expanded-columns)
  1110. (aref widths i))))))))
  1111. widths))
  1112. (defun shr-make-table (cont widths &optional fill)
  1113. (let ((trs nil))
  1114. (dolist (row cont)
  1115. (when (eq (car row) 'tr)
  1116. (let ((tds nil)
  1117. (columns (cdr row))
  1118. (i 0)
  1119. column)
  1120. (while (< i (length widths))
  1121. (setq column (pop columns))
  1122. (when (or (memq (car column) '(td th))
  1123. (null column))
  1124. (push (shr-render-td (cdr column) (aref widths i) fill)
  1125. tds)
  1126. (setq i (1+ i))))
  1127. (push (nreverse tds) trs))))
  1128. (nreverse trs)))
  1129. (defun shr-render-td (cont width fill)
  1130. (with-temp-buffer
  1131. (let ((bgcolor (cdr (assq :bgcolor cont)))
  1132. (fgcolor (cdr (assq :fgcolor cont)))
  1133. (style (cdr (assq :style cont)))
  1134. (shr-stylesheet shr-stylesheet)
  1135. overlays actual-colors)
  1136. (when style
  1137. (setq style (and (string-match "color" style)
  1138. (shr-parse-style style))))
  1139. (when bgcolor
  1140. (setq style (nconc (list (cons 'background-color bgcolor)) style)))
  1141. (when fgcolor
  1142. (setq style (nconc (list (cons 'color fgcolor)) style)))
  1143. (when style
  1144. (setq shr-stylesheet (append style shr-stylesheet)))
  1145. (let ((cache (cdr (assoc (cons width cont) shr-content-cache))))
  1146. (if cache
  1147. (progn
  1148. (insert (car cache))
  1149. (let ((end (length (car cache))))
  1150. (dolist (overlay (cadr cache))
  1151. (let ((new-overlay
  1152. (make-overlay (1+ (- end (nth 0 overlay)))
  1153. (1+ (- end (nth 1 overlay)))))
  1154. (properties (nth 2 overlay)))
  1155. (while properties
  1156. (overlay-put new-overlay
  1157. (pop properties) (pop properties)))))))
  1158. (let ((shr-width width)
  1159. (shr-indentation 0))
  1160. (shr-descend (cons 'td cont)))
  1161. ;; Delete padding at the bottom of the TDs.
  1162. (delete-region
  1163. (point)
  1164. (progn
  1165. (skip-chars-backward " \t\n")
  1166. (end-of-line)
  1167. (point)))
  1168. (push (list (cons width cont) (buffer-string)
  1169. (shr-overlays-in-region (point-min) (point-max)))
  1170. shr-content-cache)))
  1171. (goto-char (point-min))
  1172. (let ((max 0))
  1173. (while (not (eobp))
  1174. (end-of-line)
  1175. (setq max (max max (current-column)))
  1176. (forward-line 1))
  1177. (when fill
  1178. (goto-char (point-min))
  1179. ;; If the buffer is totally empty, then put a single blank
  1180. ;; line here.
  1181. (if (zerop (buffer-size))
  1182. (insert (make-string width ? ))
  1183. ;; Otherwise, fill the buffer.
  1184. (while (not (eobp))
  1185. (end-of-line)
  1186. (when (> (- width (current-column)) 0)
  1187. (insert (make-string (- width (current-column)) ? )))
  1188. (forward-line 1)))
  1189. (when style
  1190. (setq actual-colors
  1191. (shr-colorize-region
  1192. (point-min) (point-max)
  1193. (cdr (assq 'color shr-stylesheet))
  1194. (cdr (assq 'background-color shr-stylesheet))))))
  1195. (if fill
  1196. (list max
  1197. (count-lines (point-min) (point-max))
  1198. (split-string (buffer-string) "\n")
  1199. (shr-collect-overlays)
  1200. (car actual-colors))
  1201. max)))))
  1202. (defun shr-buffer-width ()
  1203. (goto-char (point-min))
  1204. (let ((max 0))
  1205. (while (not (eobp))
  1206. (end-of-line)
  1207. (setq max (max max (current-column)))
  1208. (forward-line 1))
  1209. max))
  1210. (defun shr-collect-overlays ()
  1211. (save-excursion
  1212. (goto-char (point-min))
  1213. (let ((overlays nil))
  1214. (while (not (eobp))
  1215. (push (shr-overlays-in-region (point) (line-end-position))
  1216. overlays)
  1217. (forward-line 1))
  1218. (nreverse overlays))))
  1219. (defun shr-overlays-in-region (start end)
  1220. (let (result)
  1221. (dolist (overlay (overlays-in start end))
  1222. (push (list (if (> start (overlay-start overlay))
  1223. (- end start)
  1224. (- end (overlay-start overlay)))
  1225. (if (< end (overlay-end overlay))
  1226. 0
  1227. (- end (overlay-end overlay)))
  1228. (overlay-properties overlay))
  1229. result))
  1230. (nreverse result)))
  1231. (defun shr-pro-rate-columns (columns)
  1232. (let ((total-percentage 0)
  1233. (widths (make-vector (length columns) 0)))
  1234. (dotimes (i (length columns))
  1235. (setq total-percentage (+ total-percentage (aref columns i))))
  1236. (setq total-percentage (/ 1.0 total-percentage))
  1237. (dotimes (i (length columns))
  1238. (aset widths i (max (truncate (* (aref columns i)
  1239. total-percentage
  1240. (- shr-width (1+ (length columns)))))
  1241. 10)))
  1242. widths))
  1243. ;; Return a summary of the number and shape of the TDs in the table.
  1244. (defun shr-column-specs (cont)
  1245. (let ((columns (make-vector (shr-max-columns cont) 1)))
  1246. (dolist (row cont)
  1247. (when (eq (car row) 'tr)
  1248. (let ((i 0))
  1249. (dolist (column (cdr row))
  1250. (when (memq (car column) '(td th))
  1251. (let ((width (cdr (assq :width (cdr column)))))
  1252. (when (and width
  1253. (string-match "\\([0-9]+\\)%" width)
  1254. (not (zerop (setq width (string-to-number
  1255. (match-string 1 width))))))
  1256. (aset columns i (/ width 100.0))))
  1257. (setq i (1+ i)))))))
  1258. columns))
  1259. (defun shr-count (cont elem)
  1260. (let ((i 0))
  1261. (dolist (sub cont)
  1262. (when (eq (car sub) elem)
  1263. (setq i (1+ i))))
  1264. i))
  1265. (defun shr-max-columns (cont)
  1266. (let ((max 0))
  1267. (dolist (row cont)
  1268. (when (eq (car row) 'tr)
  1269. (setq max (max max (+ (shr-count (cdr row) 'td)
  1270. (shr-count (cdr row) 'th))))))
  1271. max))
  1272. (provide 'shr)
  1273. ;;; shr.el ends here