2013-06-18 Glenn Morris <rgm@gnu.org>
+ * net/eww.el, net/shr.el, net/shr-color.el: Move here from gnus/.
+
* newcomment.el (comment-search-forward, comment-search-backward):
Doc fix. (Bug#14376)
+2013-06-18 Glenn Morris <rgm@gnu.org>
+
+ * eww.el, shr.el, shr-color.el: Move to ../net.
+
2013-06-18 Lars Magne Ingebrigtsen <larsi@gnus.org>
* shr.el (shr-tag-table): Insert the images after the table, so that
+++ /dev/null
-;;; eww.el --- Emacs Web Wowser
-
-;; Copyright (C) 2013 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: html
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'format-spec)
-(require 'shr)
-(require 'url)
-(require 'mm-url)
-
-(defgroup eww nil
- "Emacs Web Wowser"
- :version "24.4"
- :group 'hypermedia
- :prefix "eww-")
-
-(defcustom eww-header-line-format "%t: %u"
- "Header line format.
-- %t is replaced by the title.
-- %u is replaced by the URL."
- :group 'eww
- :type 'string)
-
-(defface eww-button
- '((((type x w32 ns) (class color)) ; Like default mode line
- :box (:line-width 2 :style released-button)
- :background "lightgrey" :foreground "black"))
- "Face for eww buffer buttons."
- :version "24.4"
- :group 'eww)
-
-(defvar eww-current-url nil)
-(defvar eww-current-title ""
- "Title of current page.")
-(defvar eww-history nil)
-
-;;;###autoload
-(defun eww (url)
- "Fetch URL and render the page."
- (interactive "sUrl: ")
- (unless (string-match-p "\\`[a-zA-Z][-a-zA-Z0-9+.]*://" url)
- (setq url (concat "http://" url)))
- (url-retrieve url 'eww-render (list url)))
-
-(defun eww-render (status url &optional point)
- (let ((redirect (plist-get status :redirect)))
- (when redirect
- (setq url redirect)))
- (let* ((headers (eww-parse-headers))
- (shr-target-id
- (and (string-match "#\\(.*\\)" url)
- (match-string 1 url)))
- (content-type
- (mail-header-parse-content-type
- (or (cdr (assoc "content-type" headers))
- "text/plain")))
- (charset (intern
- (downcase
- (or (cdr (assq 'charset (cdr content-type)))
- (eww-detect-charset (equal (car content-type)
- "text/html"))
- "utf8"))))
- (data-buffer (current-buffer)))
- (unwind-protect
- (progn
- (cond
- ((equal (car content-type) "text/html")
- (eww-display-html charset url))
- ((string-match "^image/" (car content-type))
- (eww-display-image))
- (t
- (eww-display-raw charset)))
- (cond
- (point
- (goto-char point))
- (shr-target-id
- (let ((point (next-single-property-change
- (point-min) 'shr-target-id)))
- (when point
- (goto-char (1+ point)))))))
- (kill-buffer data-buffer))))
-
-(defun eww-parse-headers ()
- (let ((headers nil))
- (goto-char (point-min))
- (while (and (not (eobp))
- (not (eolp)))
- (when (looking-at "\\([^:]+\\): *\\(.*\\)")
- (push (cons (downcase (match-string 1))
- (match-string 2))
- headers))
- (forward-line 1))
- (unless (eobp)
- (forward-line 1))
- headers))
-
-(defun eww-detect-charset (html-p)
- (let ((case-fold-search t)
- (pt (point)))
- (or (and html-p
- (re-search-forward
- "<meta[\t\n\r ]+[^>]*charset=\"?\\([^\t\n\r \"/>]+\\)" nil t)
- (goto-char pt)
- (match-string 1))
- (and (looking-at
- "[\t\n\r ]*<\\?xml[\t\n\r ]+[^>]*encoding=\"\\([^\"]+\\)")
- (match-string 1)))))
-
-(defun eww-display-html (charset url)
- (unless (eq charset 'utf8)
- (decode-coding-region (point) (point-max) charset))
- (let ((document
- (list
- 'base (list (cons 'href url))
- (libxml-parse-html-region (point) (point-max)))))
- (eww-setup-buffer)
- (setq eww-current-url url)
- (eww-update-header-line-format)
- (let ((inhibit-read-only t)
- (shr-width nil)
- (shr-external-rendering-functions
- '((title . eww-tag-title)
- (form . eww-tag-form)
- (input . eww-tag-input)
- (textarea . eww-tag-textarea)
- (body . eww-tag-body)
- (select . eww-tag-select))))
- (shr-insert-document document)
- (eww-convert-widgets))
- (goto-char (point-min))))
-
-(defun eww-update-header-line-format ()
- (if eww-header-line-format
- (setq header-line-format (format-spec eww-header-line-format
- `((?u . ,eww-current-url)
- (?t . ,eww-current-title))))
- (setq header-line-format nil)))
-
-(defun eww-tag-title (cont)
- (setq eww-current-title "")
- (dolist (sub cont)
- (when (eq (car sub) 'text)
- (setq eww-current-title (concat eww-current-title (cdr sub)))))
- (eww-update-header-line-format))
-
-(defun eww-tag-body (cont)
- (let* ((start (point))
- (fgcolor (cdr (or (assq :fgcolor cont)
- (assq :text cont))))
- (bgcolor (cdr (assq :bgcolor cont)))
- (shr-stylesheet (list (cons 'color fgcolor)
- (cons 'background-color bgcolor))))
- (shr-generic cont)
- (eww-colorize-region start (point) fgcolor bgcolor)))
-
-(defun eww-colorize-region (start end fg &optional bg)
- (when (or fg bg)
- (let ((new-colors (shr-color-check fg bg)))
- (when new-colors
- (when fg
- (add-face-text-property start end
- (list :foreground (cadr new-colors))))
- (when bg
- (add-face-text-property start end
- (list :background (car new-colors))))))))
-
-(defun eww-display-raw (charset)
- (let ((data (buffer-substring (point) (point-max))))
- (eww-setup-buffer)
- (let ((inhibit-read-only t))
- (insert data))
- (goto-char (point-min))))
-
-(defun eww-display-image ()
- (let ((data (buffer-substring (point) (point-max))))
- (eww-setup-buffer)
- (let ((inhibit-read-only t))
- (shr-put-image data nil))
- (goto-char (point-min))))
-
-(defun eww-setup-buffer ()
- (pop-to-buffer (get-buffer-create "*eww*"))
- (remove-overlays)
- (setq widget-field-list nil)
- (let ((inhibit-read-only t))
- (erase-buffer))
- (eww-mode))
-
-(defvar eww-mode-map
- (let ((map (make-sparse-keymap)))
- (suppress-keymap map)
- (define-key map "q" 'eww-quit)
- (define-key map "g" 'eww-reload)
- (define-key map [tab] 'shr-next-link)
- (define-key map [backtab] 'shr-previous-link)
- (define-key map [delete] 'scroll-down-command)
- (define-key map "\177" 'scroll-down-command)
- (define-key map " " 'scroll-up-command)
- (define-key map "p" 'eww-previous-url)
- ;;(define-key map "n" 'eww-next-url)
- map))
-
-(define-derived-mode eww-mode nil "eww"
- "Mode for browsing the web.
-
-\\{eww-mode-map}"
- (set (make-local-variable 'eww-current-url) 'author)
- (set (make-local-variable 'browse-url-browser-function) 'eww-browse-url))
-
-(defun eww-browse-url (url &optional new-window)
- (push (list eww-current-url (point))
- eww-history)
- (eww url))
-
-(defun eww-quit ()
- "Exit the Emacs Web Wowser."
- (interactive)
- (setq eww-history nil)
- (kill-buffer (current-buffer)))
-
-(defun eww-previous-url ()
- "Go to the previously displayed page."
- (interactive)
- (when (zerop (length eww-history))
- (error "No previous page"))
- (let ((prev (pop eww-history)))
- (url-retrieve (car prev) 'eww-render (list (car prev) (cadr prev)))))
-
-(defun eww-reload ()
- "Reload the current page."
- (interactive)
- (url-retrieve eww-current-url 'eww-render
- (list eww-current-url (point))))
-
-;; Form support.
-
-(defvar eww-form nil)
-
-(defun eww-tag-form (cont)
- (let ((eww-form
- (list (assq :method cont)
- (assq :action cont)))
- (start (point)))
- (shr-ensure-paragraph)
- (shr-generic cont)
- (unless (bolp)
- (insert "\n"))
- (insert "\n")
- (when (> (point) start)
- (put-text-property start (1+ start)
- 'eww-form eww-form))))
-
-(defun eww-tag-input (cont)
- (let* ((start (point))
- (type (downcase (or (cdr (assq :type cont))
- "text")))
- (value (cdr (assq :value cont)))
- (widget
- (cond
- ((or (equal type "submit")
- (equal type "image"))
- (list 'push-button
- :notify 'eww-submit
- :name (cdr (assq :name cont))
- :value (if (zerop (length value))
- "Submit"
- value)
- :eww-form eww-form
- (or (if (zerop (length value))
- "Submit"
- value))))
- ((or (equal type "radio")
- (equal type "checkbox"))
- (list 'checkbox
- :notify 'eww-click-radio
- :name (cdr (assq :name cont))
- :checkbox-value value
- :checkbox-type type
- :eww-form eww-form
- (cdr (assq :checked cont))))
- ((equal type "hidden")
- (list 'hidden
- :name (cdr (assq :name cont))
- :value value))
- (t
- (list 'editable-field
- :size (string-to-number
- (or (cdr (assq :size cont))
- "40"))
- :value (or value "")
- :secret (and (equal type "password") ?*)
- :action 'eww-submit
- :name (cdr (assq :name cont))
- :eww-form eww-form)))))
- (nconc eww-form (list widget))
- (unless (eq (car widget) 'hidden)
- (apply 'widget-create widget)
- (put-text-property start (point) 'eww-widget widget)
- (insert " "))))
-
-(defun eww-tag-textarea (cont)
- (let* ((start (point))
- (widget
- (list 'text
- :size (string-to-number
- (or (cdr (assq :cols cont))
- "40"))
- :value (or (cdr (assq 'text cont)) "")
- :action 'eww-submit
- :name (cdr (assq :name cont))
- :eww-form eww-form)))
- (nconc eww-form (list widget))
- (apply 'widget-create widget)
- (put-text-property start (point) 'eww-widget widget)))
-
-(defun eww-tag-select (cont)
- (shr-ensure-paragraph)
- (let ((menu (list 'menu-choice
- :name (cdr (assq :name cont))
- :eww-form eww-form))
- (options nil)
- (start (point)))
- (dolist (elem cont)
- (when (eq (car elem) 'option)
- (when (cdr (assq :selected (cdr elem)))
- (nconc menu (list :value
- (cdr (assq :value (cdr elem))))))
- (push (list 'item
- :value (cdr (assq :value (cdr elem)))
- :tag (cdr (assq 'text (cdr elem))))
- options)))
- (when options
- ;; If we have no selected values, default to the first value.
- (unless (plist-get (cdr menu) :value)
- (nconc menu (list :value (nth 2 (car options)))))
- (nconc menu options)
- (apply 'widget-create menu)
- (put-text-property start (point) 'eww-widget menu)
- (shr-ensure-paragraph))))
-
-(defun eww-click-radio (widget &rest ignore)
- (let ((form (plist-get (cdr widget) :eww-form))
- (name (plist-get (cdr widget) :name)))
- (when (equal (plist-get (cdr widget) :type) "radio")
- (if (widget-value widget)
- ;; Switch all the other radio buttons off.
- (dolist (overlay (overlays-in (point-min) (point-max)))
- (let ((field (plist-get (overlay-properties overlay) 'button)))
- (when (and (eq (plist-get (cdr field) :eww-form) form)
- (equal name (plist-get (cdr field) :name)))
- (unless (eq field widget)
- (widget-value-set field nil)))))
- (widget-value-set widget t)))
- (eww-fix-widget-keymap)))
-
-(defun eww-submit (widget &rest ignore)
- (let ((form (plist-get (cdr widget) :eww-form))
- values)
- (dolist (overlay (sort (overlays-in (point-min) (point-max))
- (lambda (o1 o2)
- (< (overlay-start o1) (overlay-start o2)))))
- (let ((field (or (plist-get (overlay-properties overlay) 'field)
- (plist-get (overlay-properties overlay) 'button))))
- (when (eq (plist-get (cdr field) :eww-form) form)
- (let ((name (plist-get (cdr field) :name)))
- (when name
- (cond
- ((eq (car field) 'checkbox)
- (when (widget-value field)
- (push (cons name (plist-get (cdr field) :checkbox-value))
- values)))
- ((eq (car field) 'push-button)
- ;; We want the values from buttons if we hit a button,
- ;; if it's the first button in the DOM after the field
- ;; hit ENTER on.
- (when (and (eq (car widget) 'push-button)
- (eq widget field))
- (push (cons name (widget-value field))
- values)))
- (t
- (push (cons name (widget-value field))
- values))))))))
- (dolist (elem form)
- (when (and (consp elem)
- (eq (car elem) 'hidden))
- (push (cons (plist-get (cdr elem) :name)
- (plist-get (cdr elem) :value))
- values)))
- ;; If we hit ENTER in a non-button field, include the value of the
- ;; first submit button after it.
- (unless (eq (car widget) 'push-button)
- (let ((rest form)
- (name (plist-get (cdr widget) :name)))
- (when rest
- (while (and rest
- (or (not (consp (car rest)))
- (not (equal name (plist-get (cdar rest) :name)))))
- (pop rest)))
- (while rest
- (let ((elem (pop rest)))
- (when (and (consp (car rest))
- (eq (car elem) 'push-button))
- (push (cons (plist-get (cdr elem) :name)
- (plist-get (cdr elem) :value))
- values)
- (setq rest nil))))))
- (if (and (stringp (cdr (assq :method form)))
- (equal (downcase (cdr (assq :method form))) "post"))
- (let ((url-request-method "POST")
- (url-request-extra-headers
- '(("Content-Type" . "application/x-www-form-urlencoded")))
- (url-request-data (mm-url-encode-www-form-urlencoded values)))
- (eww-browse-url (shr-expand-url (cdr (assq :action form))
- eww-current-url)))
- (eww-browse-url
- (concat
- (if (cdr (assq :action form))
- (shr-expand-url (cdr (assq :action form))
- eww-current-url)
- eww-current-url)
- "?"
- (mm-url-encode-www-form-urlencoded values))))))
-
-(defun eww-convert-widgets ()
- (let ((start (point-min))
- widget)
- ;; Some widgets come from different buffers (rendered for tables),
- ;; so we need to nix out the list of widgets and recreate them.
- (setq widget-field-list nil
- widget-field-new nil)
- (while (setq start (if (get-text-property start 'eww-widget)
- start
- (next-single-property-change start 'eww-widget)))
- (setq widget (get-text-property start 'eww-widget))
- (goto-char start)
- (let ((end (next-single-property-change start 'eww-widget)))
- (dolist (overlay (overlays-in start end))
- (when (or (plist-get (overlay-properties overlay) 'button)
- (plist-get (overlay-properties overlay) 'field))
- (delete-overlay overlay)))
- (delete-region start end))
- (when (and widget
- (not (eq (car widget) 'hidden)))
- (apply 'widget-create widget)
- (put-text-property start (point) 'help-echo
- (if (memq (car widget) '(text editable-field))
- "Input field"
- "Button"))
- (when (eq (car widget) 'push-button)
- (add-face-text-property start (point) 'eww-button t))))
- (widget-setup)
- (eww-fix-widget-keymap)))
-
-(defun eww-fix-widget-keymap ()
- (dolist (overlay (overlays-in (point-min) (point-max)))
- (when (plist-get (overlay-properties overlay) 'button)
- (overlay-put overlay 'local-map widget-keymap))))
-
-(provide 'eww)
-
-;;; eww.el ends here
+++ /dev/null
-;;; shr-color.el --- Simple HTML Renderer color management
-
-;; Copyright (C) 2010-2013 Free Software Foundation, Inc.
-
-;; Author: Julien Danjou <julien@danjou.info>
-;; Keywords: html
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This package handles colors display for shr.
-
-;;; Code:
-
-(require 'color)
-(eval-when-compile (require 'cl))
-
-(defgroup shr-color nil
- "Simple HTML Renderer colors"
- :group 'shr)
-
-(defcustom shr-color-visible-luminance-min 40
- "Minimum luminance distance between two colors to be considered visible.
-Must be between 0 and 100."
- :group 'shr-color
- :type 'number)
-
-(defcustom shr-color-visible-distance-min 5
- "Minimum color distance between two colors to be considered visible.
-This value is used to compare result for `ciede2000'. It's an
-absolute value without any unit."
- :group 'shr-color
- :type 'integer)
-
-(defconst shr-color-html-colors-alist
- '(("AliceBlue" . "#F0F8FF")
- ("AntiqueWhite" . "#FAEBD7")
- ("Aqua" . "#00FFFF")
- ("Aquamarine" . "#7FFFD4")
- ("Azure" . "#F0FFFF")
- ("Beige" . "#F5F5DC")
- ("Bisque" . "#FFE4C4")
- ("Black" . "#000000")
- ("BlanchedAlmond" . "#FFEBCD")
- ("Blue" . "#0000FF")
- ("BlueViolet" . "#8A2BE2")
- ("Brown" . "#A52A2A")
- ("BurlyWood" . "#DEB887")
- ("CadetBlue" . "#5F9EA0")
- ("Chartreuse" . "#7FFF00")
- ("Chocolate" . "#D2691E")
- ("Coral" . "#FF7F50")
- ("CornflowerBlue" . "#6495ED")
- ("Cornsilk" . "#FFF8DC")
- ("Crimson" . "#DC143C")
- ("Cyan" . "#00FFFF")
- ("DarkBlue" . "#00008B")
- ("DarkCyan" . "#008B8B")
- ("DarkGoldenRod" . "#B8860B")
- ("DarkGray" . "#A9A9A9")
- ("DarkGrey" . "#A9A9A9")
- ("DarkGreen" . "#006400")
- ("DarkKhaki" . "#BDB76B")
- ("DarkMagenta" . "#8B008B")
- ("DarkOliveGreen" . "#556B2F")
- ("Darkorange" . "#FF8C00")
- ("DarkOrchid" . "#9932CC")
- ("DarkRed" . "#8B0000")
- ("DarkSalmon" . "#E9967A")
- ("DarkSeaGreen" . "#8FBC8F")
- ("DarkSlateBlue" . "#483D8B")
- ("DarkSlateGray" . "#2F4F4F")
- ("DarkSlateGrey" . "#2F4F4F")
- ("DarkTurquoise" . "#00CED1")
- ("DarkViolet" . "#9400D3")
- ("DeepPink" . "#FF1493")
- ("DeepSkyBlue" . "#00BFFF")
- ("DimGray" . "#696969")
- ("DimGrey" . "#696969")
- ("DodgerBlue" . "#1E90FF")
- ("FireBrick" . "#B22222")
- ("FloralWhite" . "#FFFAF0")
- ("ForestGreen" . "#228B22")
- ("Fuchsia" . "#FF00FF")
- ("Gainsboro" . "#DCDCDC")
- ("GhostWhite" . "#F8F8FF")
- ("Gold" . "#FFD700")
- ("GoldenRod" . "#DAA520")
- ("Gray" . "#808080")
- ("Grey" . "#808080")
- ("Green" . "#008000")
- ("GreenYellow" . "#ADFF2F")
- ("HoneyDew" . "#F0FFF0")
- ("HotPink" . "#FF69B4")
- ("IndianRed" . "#CD5C5C")
- ("Indigo" . "#4B0082")
- ("Ivory" . "#FFFFF0")
- ("Khaki" . "#F0E68C")
- ("Lavender" . "#E6E6FA")
- ("LavenderBlush" . "#FFF0F5")
- ("LawnGreen" . "#7CFC00")
- ("LemonChiffon" . "#FFFACD")
- ("LightBlue" . "#ADD8E6")
- ("LightCoral" . "#F08080")
- ("LightCyan" . "#E0FFFF")
- ("LightGoldenRodYellow" . "#FAFAD2")
- ("LightGray" . "#D3D3D3")
- ("LightGrey" . "#D3D3D3")
- ("LightGreen" . "#90EE90")
- ("LightPink" . "#FFB6C1")
- ("LightSalmon" . "#FFA07A")
- ("LightSeaGreen" . "#20B2AA")
- ("LightSkyBlue" . "#87CEFA")
- ("LightSlateGray" . "#778899")
- ("LightSlateGrey" . "#778899")
- ("LightSteelBlue" . "#B0C4DE")
- ("LightYellow" . "#FFFFE0")
- ("Lime" . "#00FF00")
- ("LimeGreen" . "#32CD32")
- ("Linen" . "#FAF0E6")
- ("Magenta" . "#FF00FF")
- ("Maroon" . "#800000")
- ("MediumAquaMarine" . "#66CDAA")
- ("MediumBlue" . "#0000CD")
- ("MediumOrchid" . "#BA55D3")
- ("MediumPurple" . "#9370D8")
- ("MediumSeaGreen" . "#3CB371")
- ("MediumSlateBlue" . "#7B68EE")
- ("MediumSpringGreen" . "#00FA9A")
- ("MediumTurquoise" . "#48D1CC")
- ("MediumVioletRed" . "#C71585")
- ("MidnightBlue" . "#191970")
- ("MintCream" . "#F5FFFA")
- ("MistyRose" . "#FFE4E1")
- ("Moccasin" . "#FFE4B5")
- ("NavajoWhite" . "#FFDEAD")
- ("Navy" . "#000080")
- ("OldLace" . "#FDF5E6")
- ("Olive" . "#808000")
- ("OliveDrab" . "#6B8E23")
- ("Orange" . "#FFA500")
- ("OrangeRed" . "#FF4500")
- ("Orchid" . "#DA70D6")
- ("PaleGoldenRod" . "#EEE8AA")
- ("PaleGreen" . "#98FB98")
- ("PaleTurquoise" . "#AFEEEE")
- ("PaleVioletRed" . "#D87093")
- ("PapayaWhip" . "#FFEFD5")
- ("PeachPuff" . "#FFDAB9")
- ("Peru" . "#CD853F")
- ("Pink" . "#FFC0CB")
- ("Plum" . "#DDA0DD")
- ("PowderBlue" . "#B0E0E6")
- ("Purple" . "#800080")
- ("Red" . "#FF0000")
- ("RosyBrown" . "#BC8F8F")
- ("RoyalBlue" . "#4169E1")
- ("SaddleBrown" . "#8B4513")
- ("Salmon" . "#FA8072")
- ("SandyBrown" . "#F4A460")
- ("SeaGreen" . "#2E8B57")
- ("SeaShell" . "#FFF5EE")
- ("Sienna" . "#A0522D")
- ("Silver" . "#C0C0C0")
- ("SkyBlue" . "#87CEEB")
- ("SlateBlue" . "#6A5ACD")
- ("SlateGray" . "#708090")
- ("SlateGrey" . "#708090")
- ("Snow" . "#FFFAFA")
- ("SpringGreen" . "#00FF7F")
- ("SteelBlue" . "#4682B4")
- ("Tan" . "#D2B48C")
- ("Teal" . "#008080")
- ("Thistle" . "#D8BFD8")
- ("Tomato" . "#FF6347")
- ("Turquoise" . "#40E0D0")
- ("Violet" . "#EE82EE")
- ("Wheat" . "#F5DEB3")
- ("White" . "#FFFFFF")
- ("WhiteSmoke" . "#F5F5F5")
- ("Yellow" . "#FFFF00")
- ("YellowGreen" . "#9ACD32"))
- "Alist of HTML colors.
-Each entry should have the form (COLOR-NAME . HEXADECIMAL-COLOR).")
-
-(defun shr-color-relative-to-absolute (number)
- "Convert a relative NUMBER to absolute.
-If NUMBER is absolute, return NUMBER.
-This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"."
- (let ((string-length (- (length number) 1)))
- ;; Is this a number with %?
- (if (eq (elt number string-length) ?%)
- (/ (* (string-to-number (substring number 0 string-length)) 255) 100)
- (string-to-number number))))
-
-(defun shr-color-hue-to-rgb (x y h)
- "Convert X Y H to RGB value."
- (when (< h 0) (incf h))
- (when (> h 1) (decf h))
- (cond ((< h (/ 1 6.0)) (+ x (* (- y x) h 6)))
- ((< h 0.5) y)
- ((< h (/ 2.0 3.0)) (+ x (* (- y x) (- (/ 2.0 3.0) h) 6)))
- (t x)))
-
-(defun shr-color-hsl-to-rgb-fractions (h s l)
- "Convert H S L to fractional RGB values."
- (let (m1 m2)
- (if (<= l 0.5)
- (setq m2 (* l (+ s 1)))
- (setq m2 (- (+ l s) (* l s))))
- (setq m1 (- (* l 2) m2))
- (list (shr-color-hue-to-rgb m1 m2 (+ h (/ 1 3.0)))
- (shr-color-hue-to-rgb m1 m2 h)
- (shr-color-hue-to-rgb m1 m2 (- h (/ 1 3.0))))))
-
-(defun shr-color->hexadecimal (color)
- "Convert any color format to hexadecimal representation.
-Like rgb() or hsl()."
- (when color
- (cond
- ;; Hexadecimal color: #abc or #aabbcc
- ((string-match
- "\\(#[0-9a-fA-F]\\{3\\}[0-9a-fA-F]\\{3\\}?\\)"
- color)
- (match-string 1 color))
- ;; rgb() or rgba() colors
- ((or (string-match
- "rgb(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*)"
- color)
- (string-match
- "rgba(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)"
- color))
- (format "#%02X%02X%02X"
- (shr-color-relative-to-absolute (match-string-no-properties 1 color))
- (shr-color-relative-to-absolute (match-string-no-properties 2 color))
- (shr-color-relative-to-absolute (match-string-no-properties 3 color))))
- ;; hsl() or hsla() colors
- ((or (string-match
- "hsl(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*)"
- color)
- (string-match
- "hsla(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)"
- color))
- (let ((h (/ (string-to-number (match-string-no-properties 1 color)) 360.0))
- (s (/ (string-to-number (match-string-no-properties 2 color)) 100.0))
- (l (/ (string-to-number (match-string-no-properties 3 color)) 100.0)))
- (destructuring-bind (r g b)
- (shr-color-hsl-to-rgb-fractions h s l)
- (color-rgb-to-hex r g b))))
- ;; Color names
- ((cdr (assoc-string color shr-color-html-colors-alist t)))
- ;; Unrecognized color :(
- (t
- nil))))
-
-(defun shr-color-set-minimum-interval (val1 val2 min max interval
- &optional fixed)
- "Set minimum interval between VAL1 and VAL2 to INTERVAL.
-The values are bound by MIN and MAX.
-If FIXED is t, then VAL1 will not be touched."
- (let ((diff (abs (- val1 val2))))
- (unless (>= diff interval)
- (if fixed
- (let* ((missing (- interval diff))
- ;; If val2 > val1, try to increase val2
- ;; That's the "good direction"
- (val2-good-direction
- (if (> val2 val1)
- (min max (+ val2 missing))
- (max min (- val2 missing))))
- (diff-val2-good-direction-val1 (abs (- val2-good-direction val1))))
- (if (>= diff-val2-good-direction-val1 interval)
- (setq val2 val2-good-direction)
- ;; Good-direction is not so good, compute bad-direction
- (let* ((val2-bad-direction
- (if (> val2 val1)
- (max min (- val1 interval))
- (min max (+ val1 interval))))
- (diff-val2-bad-direction-val1 (abs (- val2-bad-direction val1))))
- (if (>= diff-val2-bad-direction-val1 interval)
- (setq val2 val2-bad-direction)
- ;; Still not good, pick the best and prefer good direction
- (setq val2
- (if (>= diff-val2-good-direction-val1 diff-val2-bad-direction-val1)
- val2-good-direction
- val2-bad-direction))))))
- ;; No fixed, move val1 and val2
- (let ((missing (/ (- interval diff) 2.0)))
- (if (< val1 val2)
- (setq val1 (max min (- val1 missing))
- val2 (min max (+ val2 missing)))
- (setq val2 (max min (- val2 missing))
- val1 (min max (+ val1 missing))))
- (setq diff (abs (- val1 val2))) ; Recompute diff
- (unless (>= diff interval)
- ;; Not ok, we hit a boundary
- (let ((missing (- interval diff)))
- (cond ((= val1 min)
- (setq val2 (+ val2 missing)))
- ((= val2 min)
- (setq val1 (+ val1 missing)))
- ((= val1 max)
- (setq val2 (- val2 missing)))
- ((= val2 max)
- (setq val1 (- val1 missing)))))))))
- (list val1 val2)))
-
-(defun shr-color-visible (bg fg &optional fixed-background)
- "Check that BG and FG colors are visible if they are drawn on each other.
-Return (bg fg) if they are. If they are too similar, two new
-colors are returned instead.
-If FIXED-BACKGROUND is set, and if the color are not visible, a
-new background color will not be computed. Only the foreground
-color will be adapted to be visible on BG."
- ;; Convert fg and bg to CIE Lab
- (let ((fg-norm (color-name-to-rgb fg))
- (bg-norm (color-name-to-rgb bg)))
- (if (or (null fg-norm)
- (null bg-norm))
- (list bg fg)
- (let* ((fg-lab (apply 'color-srgb-to-lab fg-norm))
- (bg-lab (apply 'color-srgb-to-lab bg-norm))
- ;; Compute color distance using CIE DE 2000
- (fg-bg-distance (color-cie-de2000 fg-lab bg-lab))
- ;; Compute luminance distance (subtract L component)
- (luminance-distance (abs (- (car fg-lab) (car bg-lab)))))
- (if (and (>= fg-bg-distance shr-color-visible-distance-min)
- (>= luminance-distance shr-color-visible-luminance-min))
- (list bg fg)
- ;; Not visible, try to change luminance to make them visible
- (let ((Ls (shr-color-set-minimum-interval
- (car bg-lab) (car fg-lab) 0 100
- shr-color-visible-luminance-min fixed-background)))
- (unless fixed-background
- (setcar bg-lab (car Ls)))
- (setcar fg-lab (cadr Ls))
- (list
- (if fixed-background
- bg
- (apply 'format "#%02x%02x%02x"
- (mapcar (lambda (x) (* (max (min 1 x) 0) 255))
- (apply 'color-lab-to-srgb bg-lab))))
- (apply 'format "#%02x%02x%02x"
- (mapcar (lambda (x) (* (max (min 1 x) 0) 255))
- (apply 'color-lab-to-srgb fg-lab))))))))))
-
-(provide 'shr-color)
-
-;;; shr-color.el ends here
+++ /dev/null
-;;; shr.el --- Simple HTML Renderer
-
-;; Copyright (C) 2010-2013 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: html
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This package takes a HTML parse tree (as provided by
-;; libxml-parse-html-region) and renders it in the current buffer. It
-;; does not do CSS, JavaScript or anything advanced: It's geared
-;; towards rendering typical short snippets of HTML, like what you'd
-;; find in HTML email and the like.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(eval-when-compile (require 'url)) ;For url-filename's setf handler.
-(require 'browse-url)
-
-(defgroup shr nil
- "Simple HTML Renderer"
- :version "24.1"
- :group 'mail)
-
-(defcustom shr-max-image-proportion 0.9
- "How big pictures displayed are in relation to the window they're in.
-A value of 0.7 means that they are allowed to take up 70% of the
-width and height of the window. If they are larger than this,
-and Emacs supports it, then the images will be rescaled down to
-fit these criteria."
- :version "24.1"
- :group 'shr
- :type 'float)
-
-(defcustom shr-blocked-images nil
- "Images that have URLs matching this regexp will be blocked."
- :version "24.1"
- :group 'shr
- :type '(choice (const nil) regexp))
-
-(defcustom shr-table-horizontal-line ?\s
- "Character used to draw horizontal table lines."
- :group 'shr
- :type 'character)
-
-(defcustom shr-table-vertical-line ?\s
- "Character used to draw vertical table lines."
- :group 'shr
- :type 'character)
-
-(defcustom shr-table-corner ?\s
- "Character used to draw table corners."
- :group 'shr
- :type 'character)
-
-(defcustom shr-hr-line ?-
- "Character used to draw hr lines."
- :group 'shr
- :type 'character)
-
-(defcustom shr-width fill-column
- "Frame width to use for rendering.
-May either be an integer specifying a fixed width in characters,
-or nil, meaning that the full width of the window should be
-used."
- :type '(choice (integer :tag "Fixed width in characters")
- (const :tag "Use the width of the window" nil))
- :group 'shr)
-
-(defcustom shr-bullet "* "
- "Bullet used for unordered lists.
-Alternative suggestions are:
-- \" \"
-- \" \""
- :type 'string
- :group 'shr)
-
-(defvar shr-content-function nil
- "If bound, this should be a function that will return the content.
-This is used for cid: URLs, and the function is called with the
-cid: URL as the argument.")
-
-(defvar shr-put-image-function 'shr-put-image
- "Function called to put image and alt string.")
-
-(defface shr-strike-through '((t (:strike-through t)))
- "Font for <s> elements."
- :group 'shr)
-
-(defface shr-link
- '((t (:inherit link)))
- "Font for link elements."
- :group 'shr)
-
-;;; Internal variables.
-
-(defvar shr-folding-mode nil)
-(defvar shr-state nil)
-(defvar shr-start nil)
-(defvar shr-indentation 0)
-(defvar shr-inhibit-images nil)
-(defvar shr-list-mode nil)
-(defvar shr-content-cache nil)
-(defvar shr-kinsoku-shorten nil)
-(defvar shr-table-depth 0)
-(defvar shr-stylesheet nil)
-(defvar shr-base nil)
-(defvar shr-ignore-cache nil)
-(defvar shr-external-rendering-functions nil)
-(defvar shr-target-id nil)
-(defvar shr-inhibit-decoration nil)
-
-(defvar shr-map
- (let ((map (make-sparse-keymap)))
- (define-key map "a" 'shr-show-alt-text)
- (define-key map "i" 'shr-browse-image)
- (define-key map "z" 'shr-zoom-image)
- (define-key map [tab] 'shr-next-link)
- (define-key map [backtab] 'shr-previous-link)
- (define-key map "I" 'shr-insert-image)
- (define-key map "u" 'shr-copy-url)
- (define-key map "v" 'shr-browse-url)
- (define-key map "o" 'shr-save-contents)
- (define-key map "\r" 'shr-browse-url)
- map))
-
-;; Public functions and commands.
-(declare-function libxml-parse-html-region "xml.c"
- (start end &optional base-url))
-
-(defun shr-render-buffer (buffer)
- "Display the HTML rendering of the current buffer."
- (interactive (list (current-buffer)))
- (or (fboundp 'libxml-parse-html-region)
- (error "This function requires Emacs to be compiled with libxml2"))
- (pop-to-buffer "*html*")
- (erase-buffer)
- (shr-insert-document
- (with-current-buffer buffer
- (libxml-parse-html-region (point-min) (point-max))))
- (goto-char (point-min)))
-
-(defun shr-visit-file (file)
- "Parse FILE as an HTML document, and render it in a new buffer."
- (interactive "fHTML file name: ")
- (with-temp-buffer
- (insert-file-contents file)
- (shr-render-buffer (current-buffer))))
-
-;;;###autoload
-(defun shr-insert-document (dom)
- "Render the parsed document DOM into the current buffer.
-DOM should be a parse tree as generated by
-`libxml-parse-html-region' or similar."
- (setq shr-content-cache nil)
- (let ((start (point))
- (shr-state nil)
- (shr-start nil)
- (shr-base nil)
- (shr-preliminary-table-render 0)
- (shr-width (or shr-width (window-width))))
- (shr-descend (shr-transform-dom dom))
- (shr-remove-trailing-whitespace start (point))))
-
-(defun shr-remove-trailing-whitespace (start end)
- (let ((width (window-width)))
- (save-restriction
- (narrow-to-region start end)
- (goto-char start)
- (while (not (eobp))
- (end-of-line)
- (when (> (shr-previous-newline-padding-width (current-column)) width)
- (dolist (overlay (overlays-at (point)))
- (when (overlay-get overlay 'before-string)
- (overlay-put overlay 'before-string nil))))
- (forward-line 1)))))
-
-(defun shr-copy-url ()
- "Copy the URL under point to the kill ring.
-If called twice, then try to fetch the URL and see whether it
-redirects somewhere else."
- (interactive)
- (let ((url (get-text-property (point) 'shr-url)))
- (cond
- ((not url)
- (message "No URL under point"))
- ;; Resolve redirected URLs.
- ((equal url (car kill-ring))
- (url-retrieve
- url
- (lambda (a)
- (when (and (consp a)
- (eq (car a) :redirect))
- (with-temp-buffer
- (insert (cadr a))
- (goto-char (point-min))
- ;; Remove common tracking junk from the URL.
- (when (re-search-forward ".utm_.*" nil t)
- (replace-match "" t t))
- (message "Copied %s" (buffer-string))
- (copy-region-as-kill (point-min) (point-max)))))
- nil t))
- ;; Copy the URL to the kill ring.
- (t
- (with-temp-buffer
- (insert url)
- (copy-region-as-kill (point-min) (point-max))
- (message "Copied %s" url))))))
-
-(defun shr-next-link ()
- "Skip to the next link."
- (interactive)
- (let ((skip (text-property-any (point) (point-max) 'help-echo nil)))
- (if (not (setq skip (text-property-not-all skip (point-max)
- 'help-echo nil)))
- (message "No next link")
- (goto-char skip)
- (message "%s" (get-text-property (point) 'help-echo)))))
-
-(defun shr-previous-link ()
- "Skip to the previous link."
- (interactive)
- (let ((start (point))
- (found nil))
- ;; Skip past the current link.
- (while (and (not (bobp))
- (get-text-property (point) 'help-echo))
- (forward-char -1))
- ;; Find the previous link.
- (while (and (not (bobp))
- (not (setq found (get-text-property (point) 'help-echo))))
- (forward-char -1))
- (if (not found)
- (progn
- (message "No previous link")
- (goto-char start))
- ;; Put point at the start of the link.
- (while (and (not (bobp))
- (get-text-property (point) 'help-echo))
- (forward-char -1))
- (forward-char 1)
- (message "%s" (get-text-property (point) 'help-echo)))))
-
-(defun shr-show-alt-text ()
- "Show the ALT text of the image under point."
- (interactive)
- (let ((text (get-text-property (point) 'shr-alt)))
- (if (not text)
- (message "No image under point")
- (message "%s" text))))
-
-(defun shr-browse-image (&optional copy-url)
- "Browse the image under point.
-If COPY-URL (the prefix if called interactively) is non-nil, copy
-the URL of the image to the kill buffer instead."
- (interactive "P")
- (let ((url (get-text-property (point) 'image-url)))
- (cond
- ((not url)
- (message "No image under point"))
- (copy-url
- (with-temp-buffer
- (insert url)
- (copy-region-as-kill (point-min) (point-max))
- (message "Copied %s" url)))
- (t
- (message "Browsing %s..." url)
- (browse-url url)))))
-
-(defun shr-insert-image ()
- "Insert the image under point into the buffer."
- (interactive)
- (let ((url (get-text-property (point) 'image-url)))
- (if (not url)
- (message "No image under point")
- (message "Inserting %s..." url)
- (url-retrieve url 'shr-image-fetched
- (list (current-buffer) (1- (point)) (point-marker))
- t t))))
-
-(defun shr-zoom-image ()
- "Toggle the image size.
-The size will be rotated between the default size, the original
-size, and full-buffer size."
- (interactive)
- (let ((url (get-text-property (point) 'image-url))
- (size (get-text-property (point) 'image-size))
- (buffer-read-only nil))
- (if (not url)
- (message "No image under point")
- ;; Delete the old picture.
- (while (get-text-property (point) 'image-url)
- (forward-char -1))
- (forward-char 1)
- (let ((start (point)))
- (while (get-text-property (point) 'image-url)
- (forward-char 1))
- (forward-char -1)
- (put-text-property start (point) 'display nil)
- (when (> (- (point) start) 2)
- (delete-region start (1- (point)))))
- (message "Inserting %s..." url)
- (url-retrieve url 'shr-image-fetched
- (list (current-buffer) (1- (point)) (point-marker)
- (list (cons 'size
- (cond ((or (eq size 'default)
- (null size))
- 'original)
- ((eq size 'original)
- 'full)
- ((eq size 'full)
- 'default)))))
- t))))
-
-;;; Utility functions.
-
-(defun shr-transform-dom (dom)
- (let ((result (list (pop dom))))
- (dolist (arg (pop dom))
- (push (cons (intern (concat ":" (symbol-name (car arg))) obarray)
- (cdr arg))
- result))
- (dolist (sub dom)
- (if (stringp sub)
- (push (cons 'text sub) result)
- (push (shr-transform-dom sub) result)))
- (nreverse result)))
-
-(defun shr-descend (dom)
- (let ((function
- (or
- ;; Allow other packages to override (or provide) rendering
- ;; of elements.
- (cdr (assq (car dom) shr-external-rendering-functions))
- (intern (concat "shr-tag-" (symbol-name (car dom))) obarray)))
- (style (cdr (assq :style (cdr dom))))
- (shr-stylesheet shr-stylesheet)
- (start (point)))
- (when style
- (if (string-match "color\\|display\\|border-collapse" style)
- (setq shr-stylesheet (nconc (shr-parse-style style)
- shr-stylesheet))
- (setq style nil)))
- ;; If we have a display:none, then just ignore this part of the
- ;; DOM.
- (unless (equal (cdr (assq 'display shr-stylesheet)) "none")
- (if (fboundp function)
- (funcall function (cdr dom))
- (shr-generic (cdr dom)))
- (when (and shr-target-id
- (equal (cdr (assq :id (cdr dom))) shr-target-id))
- (put-text-property start (1+ start) 'shr-target-id shr-target-id))
- ;; If style is set, then this node has set the color.
- (when style
- (shr-colorize-region start (point)
- (cdr (assq 'color shr-stylesheet))
- (cdr (assq 'background-color shr-stylesheet)))))))
-
-(defun shr-generic (cont)
- (dolist (sub cont)
- (cond
- ((eq (car sub) 'text)
- (shr-insert (cdr sub)))
- ((listp (cdr sub))
- (shr-descend sub)))))
-
-(defmacro shr-char-breakable-p (char)
- "Return non-nil if a line can be broken before and after CHAR."
- `(aref fill-find-break-point-function-table ,char))
-(defmacro shr-char-nospace-p (char)
- "Return non-nil if no space is required before and after CHAR."
- `(aref fill-nospace-between-words-table ,char))
-
-;; KINSOKU is a Japanese word meaning a rule that should not be violated.
-;; In Emacs, it is a term used for characters, e.g. punctuation marks,
-;; parentheses, and so on, that should not be placed in the beginning
-;; of a line or the end of a line.
-(defmacro shr-char-kinsoku-bol-p (char)
- "Return non-nil if a line ought not to begin with CHAR."
- `(aref (char-category-set ,char) ?>))
-(defmacro shr-char-kinsoku-eol-p (char)
- "Return non-nil if a line ought not to end with CHAR."
- `(aref (char-category-set ,char) ?<))
-(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
- (load "kinsoku" nil t))
-
-(defun shr-insert (text)
- (when (and (eq shr-state 'image)
- (not (bolp))
- (not (string-match "\\`[ \t\n]+\\'" text)))
- (insert "\n")
- (setq shr-state nil))
- (cond
- ((eq shr-folding-mode 'none)
- (insert text))
- (t
- (when (and (string-match "\\`[ \t\n ]" text)
- (not (bolp))
- (not (eq (char-after (1- (point))) ? )))
- (insert " "))
- (dolist (elem (split-string text "[ \f\t\n\r\v ]+" t))
- (when (and (bolp)
- (> shr-indentation 0))
- (shr-indent))
- ;; No space is needed behind a wide character categorized as
- ;; kinsoku-bol, between characters both categorized as nospace,
- ;; or at the beginning of a line.
- (let (prev)
- (when (and (> (current-column) shr-indentation)
- (eq (preceding-char) ? )
- (or (= (line-beginning-position) (1- (point)))
- (and (shr-char-breakable-p
- (setq prev (char-after (- (point) 2))))
- (shr-char-kinsoku-bol-p prev))
- (and (shr-char-nospace-p prev)
- (shr-char-nospace-p (aref elem 0)))))
- (delete-char -1)))
- ;; The shr-start is a special variable that is used to pass
- ;; upwards the first point in the buffer where the text really
- ;; starts.
- (unless shr-start
- (setq shr-start (point)))
- (insert elem)
- (setq shr-state nil)
- (let (found)
- (while (and (> (current-column) shr-width)
- (progn
- (setq found (shr-find-fill-point))
- (not (eolp))))
- (when (eq (preceding-char) ? )
- (delete-char -1))
- (insert "\n")
- (unless found
- ;; No space is needed at the beginning of a line.
- (when (eq (following-char) ? )
- (delete-char 1)))
- (when (> shr-indentation 0)
- (shr-indent))
- (end-of-line))
- (insert " ")))
- (unless (string-match "[ \t\r\n ]\\'" text)
- (delete-char -1)))))
-
-(defun shr-find-fill-point ()
- (when (> (move-to-column shr-width) shr-width)
- (backward-char 1))
- (let ((bp (point))
- failed)
- (while (not (or (setq failed (= (current-column) shr-indentation))
- (eq (preceding-char) ? )
- (eq (following-char) ? )
- (shr-char-breakable-p (preceding-char))
- (shr-char-breakable-p (following-char))
- (if (eq (preceding-char) ?')
- (not (memq (char-after (- (point) 2))
- (list nil ?\n ? )))
- (and (shr-char-kinsoku-bol-p (preceding-char))
- (shr-char-breakable-p (following-char))
- (not (shr-char-kinsoku-bol-p (following-char)))))
- (shr-char-kinsoku-eol-p (following-char))))
- (backward-char 1))
- (if (and (not (or failed (eolp)))
- (eq (preceding-char) ?'))
- (while (not (or (setq failed (eolp))
- (eq (following-char) ? )
- (shr-char-breakable-p (following-char))
- (shr-char-kinsoku-eol-p (following-char))))
- (forward-char 1)))
- (if failed
- ;; There's no breakable point, so we give it up.
- (let (found)
- (goto-char bp)
- (unless shr-kinsoku-shorten
- (while (and (setq found (re-search-forward
- "\\(\\c>\\)\\| \\|\\c<\\|\\c|"
- (line-end-position) 'move))
- (eq (preceding-char) ?')))
- (if (and found (not (match-beginning 1)))
- (goto-char (match-beginning 0)))))
- (or
- (eolp)
- ;; Don't put kinsoku-bol characters at the beginning of a line,
- ;; or kinsoku-eol characters at the end of a line.
- (cond
- (shr-kinsoku-shorten
- (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
- (shr-char-kinsoku-eol-p (preceding-char)))
- (backward-char 1))
- (when (setq failed (= (current-column) shr-indentation))
- ;; There's no breakable point that doesn't violate kinsoku,
- ;; so we look for the second best position.
- (while (and (progn
- (forward-char 1)
- (<= (current-column) shr-width))
- (progn
- (setq bp (point))
- (shr-char-kinsoku-eol-p (following-char)))))
- (goto-char bp)))
- ((shr-char-kinsoku-eol-p (preceding-char))
- ;; Find backward the point where kinsoku-eol characters begin.
- (let ((count 4))
- (while
- (progn
- (backward-char 1)
- (and (> (setq count (1- count)) 0)
- (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
- (or (shr-char-kinsoku-eol-p (preceding-char))
- (shr-char-kinsoku-bol-p (following-char)))))))
- (if (setq failed (= (current-column) shr-indentation))
- ;; There's no breakable point that doesn't violate kinsoku,
- ;; so we go to the second best position.
- (if (looking-at "\\(\\c<+\\)\\c<")
- (goto-char (match-end 1))
- (forward-char 1))))
- ((shr-char-kinsoku-bol-p (following-char))
- ;; Find forward the point where kinsoku-bol characters end.
- (let ((count 4))
- (while (progn
- (forward-char 1)
- (and (>= (setq count (1- count)) 0)
- (shr-char-kinsoku-bol-p (following-char))
- (shr-char-breakable-p (following-char))))))))
- (when (eq (following-char) ? )
- (forward-char 1))))
- (not failed)))
-
-(defun shr-parse-base (url)
- ;; Always chop off anchors.
- (when (string-match "#.*" url)
- (setq url (substring url 0 (match-beginning 0))))
- (let* ((parsed (url-generic-parse-url url))
- (local (url-filename parsed)))
- (setf (url-filename parsed) "")
- ;; Chop off the bit after the last slash.
- (when (string-match "\\`\\(.*/\\)[^/]+\\'" local)
- (setq local (match-string 1 local)))
- ;; Always make the local bit end with a slash.
- (when (and (not (zerop (length local)))
- (not (eq (aref local (1- (length local))) ?/)))
- (setq local (concat local "/")))
- (list (url-recreate-url parsed)
- local
- (url-type parsed)
- url)))
-
-(defun shr-expand-url (url &optional base)
- (setq base
- (if base
- (shr-parse-base base)
- ;; Bound by the parser.
- shr-base))
- (when (zerop (length url))
- (setq url nil))
- (cond ((or (not url)
- (not base)
- (string-match "\\`[a-z]*:" url))
- ;; Absolute URL.
- (or url (car base)))
- ((eq (aref url 0) ?/)
- (if (and (> (length url) 1)
- (eq (aref url 1) ?/))
- ;; //host...; just use the protocol
- (concat (nth 2 base) ":" url)
- ;; Just use the host name part.
- (concat (car base) url)))
- ((eq (aref url 0) ?#)
- ;; A link to an anchor.
- (concat (nth 3 base) url))
- (t
- ;; Totally relative.
- (concat (car base) (cadr base) url))))
-
-(defun shr-ensure-newline ()
- (unless (zerop (current-column))
- (insert "\n")))
-
-(defun shr-ensure-paragraph ()
- (unless (bobp)
- (if (<= (current-column) shr-indentation)
- (unless (save-excursion
- (forward-line -1)
- (looking-at " *$"))
- (insert "\n"))
- (if (save-excursion
- (beginning-of-line)
- ;; If the current line is totally blank, and doesn't even
- ;; have any face properties set, then delete the blank
- ;; space.
- (and (looking-at " *$")
- (not (get-text-property (point) 'face))
- (not (= (next-single-property-change (point) 'face nil
- (line-end-position))
- (line-end-position)))))
- (delete-region (match-beginning 0) (match-end 0))
- (insert "\n\n")))))
-
-(defun shr-indent ()
- (when (> shr-indentation 0)
- (insert (make-string shr-indentation ? ))))
-
-(defun shr-fontize-cont (cont &rest types)
- (let (shr-start)
- (shr-generic cont)
- (dolist (type types)
- (shr-add-font (or shr-start (point)) (point) type))))
-
-;; Add face to the region, but avoid putting the font properties on
-;; blank text at the start of the line, and the newline at the end, to
-;; avoid ugliness.
-(defun shr-add-font (start end type)
- (unless shr-inhibit-decoration
- (save-excursion
- (goto-char start)
- (while (< (point) end)
- (when (bolp)
- (skip-chars-forward " "))
- (add-face-text-property (point) (min (line-end-position) end) type t)
- (if (< (line-end-position) end)
- (forward-line 1)
- (goto-char end))))))
-
-(defun shr-browse-url ()
- "Browse the URL under point."
- (interactive)
- (let ((url (get-text-property (point) 'shr-url)))
- (cond
- ((not url)
- (message "No link under point"))
- ((string-match "^mailto:" url)
- (browse-url-mail url))
- (t
- (browse-url url)))))
-
-(defun shr-save-contents (directory)
- "Save the contents from URL in a file."
- (interactive "DSave contents of URL to directory: ")
- (let ((url (get-text-property (point) 'shr-url)))
- (if (not url)
- (message "No link under point")
- (url-retrieve (shr-encode-url url)
- 'shr-store-contents (list url directory)
- nil t))))
-
-(defun shr-store-contents (status url directory)
- (unless (plist-get status :error)
- (when (or (search-forward "\n\n" nil t)
- (search-forward "\r\n\r\n" nil t))
- (write-region (point) (point-max)
- (expand-file-name (file-name-nondirectory url)
- directory)))))
-
-(defun shr-image-fetched (status buffer start end &optional flags)
- (let ((image-buffer (current-buffer)))
- (when (and (buffer-name buffer)
- (not (plist-get status :error)))
- (url-store-in-cache image-buffer)
- (when (or (search-forward "\n\n" nil t)
- (search-forward "\r\n\r\n" nil t))
- (let ((data (buffer-substring (point) (point-max))))
- (with-current-buffer buffer
- (save-excursion
- (let ((alt (buffer-substring start end))
- (properties (text-properties-at start))
- (inhibit-read-only t))
- (delete-region start end)
- (goto-char start)
- (funcall shr-put-image-function data alt flags)
- (while properties
- (let ((type (pop properties))
- (value (pop properties)))
- (unless (memq type '(display image-size))
- (put-text-property start (point) type value))))))))))
- (kill-buffer image-buffer)))
-
-(defun shr-image-from-data (data)
- "Return an image from the data: URI content DATA."
- (when (string-match
- "\\(\\([^/;,]+\\(/[^;,]+\\)?\\)\\(;[^;,]+\\)*\\)?,\\(.*\\)"
- data)
- (let ((param (match-string 4 data))
- (payload (url-unhex-string (match-string 5 data))))
- (when (string-match "^.*\\(;[ \t]*base64\\)$" param)
- (setq payload (base64-decode-string payload)))
- payload)))
-
-(defun shr-put-image (data alt &optional flags)
- "Put image DATA with a string ALT. Return image."
- (if (display-graphic-p)
- (let* ((size (cdr (assq 'size flags)))
- (start (point))
- (image (cond
- ((eq size 'original)
- (create-image data nil t :ascent 100))
- ((eq size 'full)
- (ignore-errors
- (shr-rescale-image data t)))
- (t
- (ignore-errors
- (shr-rescale-image data))))))
- (when image
- ;; When inserting big-ish pictures, put them at the
- ;; beginning of the line.
- (when (and (> (current-column) 0)
- (> (car (image-size image t)) 400))
- (insert "\n"))
- (if (eq size 'original)
- (insert-sliced-image image (or alt "*") nil 20 1)
- (insert-image image (or alt "*")))
- (put-text-property start (point) 'image-size size)
- (when (cond ((fboundp 'image-multi-frame-p)
- ;; Only animate multi-frame things that specify a
- ;; delay; eg animated gifs as opposed to
- ;; multi-page tiffs. FIXME?
- (cdr (image-multi-frame-p image)))
- ((fboundp 'image-animated-p)
- (image-animated-p image)))
- (image-animate image nil 60)))
- image)
- (insert alt)))
-
-(defun shr-rescale-image (data &optional force)
- "Rescale DATA, if too big, to fit the current buffer.
-If FORCE, rescale the image anyway."
- (let ((image (create-image data nil t :ascent 100)))
- (if (or (not (fboundp 'imagemagick-types))
- (not (get-buffer-window (current-buffer))))
- image
- (let* ((size (image-size image t))
- (width (car size))
- (height (cdr size))
- (edges (window-inside-pixel-edges
- (get-buffer-window (current-buffer))))
- (window-width (truncate (* shr-max-image-proportion
- (- (nth 2 edges) (nth 0 edges)))))
- (window-height (truncate (* shr-max-image-proportion
- (- (nth 3 edges) (nth 1 edges)))))
- scaled-image)
- (when (or force
- (> height window-height))
- (setq image (or (create-image data 'imagemagick t
- :height window-height
- :ascent 100)
- image))
- (setq size (image-size image t)))
- (when (> (car size) window-width)
- (setq image (or
- (create-image data 'imagemagick t
- :width window-width
- :ascent 100)
- image)))
- image))))
-
-;; url-cache-extract autoloads url-cache.
-(declare-function url-cache-create-filename "url-cache" (url))
-(autoload 'mm-disable-multibyte "mm-util")
-(autoload 'browse-url-mail "browse-url")
-
-(defun shr-get-image-data (url)
- "Get image data for URL.
-Return a string with image data."
- (with-temp-buffer
- (mm-disable-multibyte)
- (when (ignore-errors
- (url-cache-extract (url-cache-create-filename (shr-encode-url url)))
- t)
- (when (or (search-forward "\n\n" nil t)
- (search-forward "\r\n\r\n" nil t))
- (buffer-substring (point) (point-max))))))
-
-(defun shr-image-displayer (content-function)
- "Return a function to display an image.
-CONTENT-FUNCTION is a function to retrieve an image for a cid url that
-is an argument. The function to be returned takes three arguments URL,
-START, and END. Note that START and END should be markers."
- `(lambda (url start end)
- (when url
- (if (string-match "\\`cid:" url)
- ,(when content-function
- `(let ((image (funcall ,content-function
- (substring url (match-end 0)))))
- (when image
- (goto-char start)
- (funcall shr-put-image-function
- image (buffer-substring start end))
- (delete-region (point) end))))
- (url-retrieve url 'shr-image-fetched
- (list (current-buffer) start end)
- t t)))))
-
-(defun shr-heading (cont &rest types)
- (shr-ensure-paragraph)
- (apply #'shr-fontize-cont cont types)
- (shr-ensure-paragraph))
-
-(defun shr-urlify (start url &optional title)
- (when (and title (string-match "ctx" title)) (debug))
- (shr-add-font start (point) 'shr-link)
- (add-text-properties
- start (point)
- (list 'shr-url url
- 'help-echo (if title (format "%s (%s)" url title) url)
- 'local-map shr-map)))
-
-(defun shr-encode-url (url)
- "Encode URL."
- (browse-url-url-encode-chars url "[)$ ]"))
-
-(autoload 'shr-color-visible "shr-color")
-(autoload 'shr-color->hexadecimal "shr-color")
-
-(defun shr-color-check (fg bg)
- "Check that FG is visible on BG.
-Returns (fg bg) with corrected values.
-Returns nil if the colors that would be used are the default
-ones, in case fg and bg are nil."
- (when (or fg bg)
- (let ((fixed (cond ((null fg) 'fg)
- ((null bg) 'bg))))
- ;; Convert colors to hexadecimal, or set them to default.
- (let ((fg (or (shr-color->hexadecimal fg)
- (frame-parameter nil 'foreground-color)))
- (bg (or (shr-color->hexadecimal bg)
- (frame-parameter nil 'background-color))))
- (cond ((eq fixed 'bg)
- ;; Only return the new fg
- (list nil (cadr (shr-color-visible bg fg t))))
- ((eq fixed 'fg)
- ;; Invert args and results and return only the new bg
- (list (cadr (shr-color-visible fg bg t)) nil))
- (t
- (shr-color-visible bg fg)))))))
-
-(defun shr-colorize-region (start end fg &optional bg)
- (when (and (not shr-inhibit-decoration)
- (or fg bg))
- (let ((new-colors (shr-color-check fg bg)))
- (when new-colors
- (when fg
- (add-face-text-property start end
- (list :foreground (cadr new-colors))
- t))
- (when bg
- (add-face-text-property start end
- (list :background (car new-colors))
- t)))
- new-colors)))
-
-(defun shr-expand-newlines (start end color)
- (save-restriction
- ;; Skip past all white space at the start and ends.
- (goto-char start)
- (skip-chars-forward " \t\n")
- (beginning-of-line)
- (setq start (point))
- (goto-char end)
- (skip-chars-backward " \t\n")
- (forward-line 1)
- (setq end (point))
- (narrow-to-region start end)
- (let ((width (shr-buffer-width))
- column)
- (goto-char (point-min))
- (while (not (eobp))
- (end-of-line)
- (when (and (< (setq column (current-column)) width)
- (< (setq column (shr-previous-newline-padding-width column))
- width))
- (let ((overlay (make-overlay (point) (1+ (point)))))
- (overlay-put overlay 'before-string
- (concat
- (mapconcat
- (lambda (overlay)
- (let ((string (plist-get
- (overlay-properties overlay)
- 'before-string)))
- (if (not string)
- ""
- (overlay-put overlay 'before-string "")
- string)))
- (overlays-at (point))
- "")
- (propertize (make-string (- width column) ? )
- 'face (list :background color))))))
- (forward-line 1)))))
-
-(defun shr-previous-newline-padding-width (width)
- (let ((overlays (overlays-at (point)))
- (previous-width 0))
- (if (null overlays)
- width
- (dolist (overlay overlays)
- (setq previous-width
- (+ previous-width
- (length (plist-get (overlay-properties overlay)
- 'before-string)))))
- (+ width previous-width))))
-
-;;; Tag-specific rendering rules.
-
-(defun shr-tag-body (cont)
- (let* ((start (point))
- (fgcolor (cdr (or (assq :fgcolor cont)
- (assq :text cont))))
- (bgcolor (cdr (assq :bgcolor cont)))
- (shr-stylesheet (list (cons 'color fgcolor)
- (cons 'background-color bgcolor))))
- (shr-generic cont)
- (shr-colorize-region start (point) fgcolor bgcolor)))
-
-(defun shr-tag-style (cont)
- )
-
-(defun shr-tag-script (cont)
- )
-
-(defun shr-tag-comment (cont)
- )
-
-(defun shr-dom-to-xml (dom)
- "Convert DOM into a string containing the xml representation."
- (let ((arg " ")
- (text ""))
- (dolist (sub (cdr dom))
- (cond
- ((listp (cdr sub))
- (setq text (concat text (shr-dom-to-xml sub))))
- ((eq (car sub) 'text)
- (setq text (concat text (cdr sub))))
- (t
- (setq arg (concat arg (format "%s=\"%s\" "
- (substring (symbol-name (car sub)) 1)
- (cdr sub)))))))
- (format "<%s%s>%s</%s>"
- (car dom)
- (substring arg 0 (1- (length arg)))
- text
- (car dom))))
-
-(defun shr-tag-svg (cont)
- (when (image-type-available-p 'svg)
- (funcall shr-put-image-function
- (shr-dom-to-xml (cons 'svg cont))
- "SVG Image")))
-
-(defun shr-tag-sup (cont)
- (let ((start (point)))
- (shr-generic cont)
- (put-text-property start (point) 'display '(raise 0.5))))
-
-(defun shr-tag-sub (cont)
- (let ((start (point)))
- (shr-generic cont)
- (put-text-property start (point) 'display '(raise -0.5))))
-
-(defun shr-tag-label (cont)
- (shr-generic cont)
- (shr-ensure-paragraph))
-
-(defun shr-tag-p (cont)
- (shr-ensure-paragraph)
- (shr-indent)
- (shr-generic cont)
- (shr-ensure-paragraph))
-
-(defun shr-tag-div (cont)
- (shr-ensure-newline)
- (shr-indent)
- (shr-generic cont)
- (shr-ensure-newline))
-
-(defun shr-tag-s (cont)
- (shr-fontize-cont cont 'shr-strike-through))
-
-(defun shr-tag-del (cont)
- (shr-fontize-cont cont 'shr-strike-through))
-
-(defun shr-tag-b (cont)
- (shr-fontize-cont cont 'bold))
-
-(defun shr-tag-i (cont)
- (shr-fontize-cont cont 'italic))
-
-(defun shr-tag-em (cont)
- (shr-fontize-cont cont 'italic))
-
-(defun shr-tag-strong (cont)
- (shr-fontize-cont cont 'bold))
-
-(defun shr-tag-u (cont)
- (shr-fontize-cont cont 'underline))
-
-(defun shr-parse-style (style)
- (when style
- (save-match-data
- (when (string-match "\n" style)
- (setq style (replace-match " " t t style))))
- (let ((plist nil))
- (dolist (elem (split-string style ";"))
- (when elem
- (setq elem (split-string elem ":"))
- (when (and (car elem)
- (cadr elem))
- (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem)))
- (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem))))
- (when (string-match " *!important\\'" value)
- (setq value (substring value 0 (match-beginning 0))))
- (push (cons (intern name obarray)
- value)
- plist)))))
- plist)))
-
-(defun shr-tag-base (cont)
- (let ((base (cdr (assq :href cont))))
- (when base
- (setq shr-base (shr-parse-base base))))
- (shr-generic cont))
-
-(defun shr-tag-a (cont)
- (let ((url (cdr (assq :href cont)))
- (title (cdr (assq :title cont)))
- (start (point))
- shr-start)
- (shr-generic cont)
- (when (and url
- (not shr-inhibit-decoration))
- (shr-urlify (or shr-start start) (shr-expand-url url) title))))
-
-(defun shr-tag-object (cont)
- (let ((start (point))
- url)
- (dolist (elem cont)
- (when (eq (car elem) 'embed)
- (setq url (or url (cdr (assq :src (cdr elem))))))
- (when (and (eq (car elem) 'param)
- (equal (cdr (assq :name (cdr elem))) "movie"))
- (setq url (or url (cdr (assq :value (cdr elem)))))))
- (when url
- (shr-insert " [multimedia] ")
- (shr-urlify start (shr-expand-url url)))
- (shr-generic cont)))
-
-(defun shr-tag-video (cont)
- (let ((image (cdr (assq :poster cont)))
- (url (cdr (assq :src cont)))
- (start (point)))
- (shr-tag-img nil image)
- (shr-urlify start (shr-expand-url url))))
-
-(defun shr-tag-img (cont &optional url)
- (when (or url
- (and cont
- (cdr (assq :src cont))))
- (when (and (> (current-column) 0)
- (not (eq shr-state 'image)))
- (insert "\n"))
- (let ((alt (cdr (assq :alt cont)))
- (url (shr-expand-url (or url (cdr (assq :src cont))))))
- (let ((start (point-marker)))
- (when (zerop (length alt))
- (setq alt "*"))
- (cond
- ((or (member (cdr (assq :height cont)) '("0" "1"))
- (member (cdr (assq :width cont)) '("0" "1")))
- ;; Ignore zero-sized or single-pixel images.
- )
- ((and (not shr-inhibit-images)
- (string-match "\\`data:" url))
- (let ((image (shr-image-from-data (substring url (match-end 0)))))
- (if image
- (funcall shr-put-image-function image alt)
- (insert alt))))
- ((and (not shr-inhibit-images)
- (string-match "\\`cid:" url))
- (let ((url (substring url (match-end 0)))
- image)
- (if (or (not shr-content-function)
- (not (setq image (funcall shr-content-function url))))
- (insert alt)
- (funcall shr-put-image-function image alt))))
- ((or shr-inhibit-images
- (and shr-blocked-images
- (string-match shr-blocked-images url)))
- (setq shr-start (point))
- (let ((shr-state 'space))
- (if (> (string-width alt) 8)
- (shr-insert (truncate-string-to-width alt 8))
- (shr-insert alt))))
- ((and (not shr-ignore-cache)
- (url-is-cached (shr-encode-url url)))
- (funcall shr-put-image-function (shr-get-image-data url) alt))
- (t
- (insert alt " ")
- (when (and shr-ignore-cache
- (url-is-cached (shr-encode-url url)))
- (let ((file (url-cache-create-filename (shr-encode-url url))))
- (when (file-exists-p file)
- (delete-file file))))
- (url-queue-retrieve
- (shr-encode-url url) 'shr-image-fetched
- (list (current-buffer) start (set-marker (make-marker) (1- (point))))
- t t)))
- (when (zerop shr-table-depth) ;; We are not in a table.
- (put-text-property start (point) 'keymap shr-map)
- (put-text-property start (point) 'shr-alt alt)
- (put-text-property start (point) 'image-url url)
- (put-text-property start (point) 'image-displayer
- (shr-image-displayer shr-content-function))
- (put-text-property start (point) 'help-echo alt))
- (setq shr-state 'image)))))
-
-(defun shr-tag-pre (cont)
- (let ((shr-folding-mode 'none))
- (shr-ensure-newline)
- (shr-indent)
- (shr-generic cont)
- (shr-ensure-newline)))
-
-(defun shr-tag-blockquote (cont)
- (shr-ensure-paragraph)
- (shr-indent)
- (let ((shr-indentation (+ shr-indentation 4)))
- (shr-generic cont))
- (shr-ensure-paragraph))
-
-(defun shr-tag-dl (cont)
- (shr-ensure-paragraph)
- (shr-generic cont)
- (shr-ensure-paragraph))
-
-(defun shr-tag-dt (cont)
- (shr-ensure-newline)
- (shr-generic cont)
- (shr-ensure-newline))
-
-(defun shr-tag-dd (cont)
- (shr-ensure-newline)
- (let ((shr-indentation (+ shr-indentation 4)))
- (shr-generic cont)))
-
-(defun shr-tag-ul (cont)
- (shr-ensure-paragraph)
- (let ((shr-list-mode 'ul))
- (shr-generic cont))
- (shr-ensure-paragraph))
-
-(defun shr-tag-ol (cont)
- (shr-ensure-paragraph)
- (let ((shr-list-mode 1))
- (shr-generic cont))
- (shr-ensure-paragraph))
-
-(defun shr-tag-li (cont)
- (shr-ensure-newline)
- (shr-indent)
- (let* ((bullet
- (if (numberp shr-list-mode)
- (prog1
- (format "%d " shr-list-mode)
- (setq shr-list-mode (1+ shr-list-mode)))
- shr-bullet))
- (shr-indentation (+ shr-indentation (length bullet))))
- (insert bullet)
- (shr-generic cont)))
-
-(defun shr-tag-br (cont)
- (when (and (not (bobp))
- ;; Only add a newline if we break the current line, or
- ;; the previous line isn't a blank line.
- (or (not (bolp))
- (and (> (- (point) 2) (point-min))
- (not (= (char-after (- (point) 2)) ?\n)))))
- (insert "\n")
- (shr-indent))
- (shr-generic cont))
-
-(defun shr-tag-span (cont)
- (shr-generic cont))
-
-(defun shr-tag-h1 (cont)
- (shr-heading cont 'bold 'underline))
-
-(defun shr-tag-h2 (cont)
- (shr-heading cont 'bold))
-
-(defun shr-tag-h3 (cont)
- (shr-heading cont 'italic))
-
-(defun shr-tag-h4 (cont)
- (shr-heading cont))
-
-(defun shr-tag-h5 (cont)
- (shr-heading cont))
-
-(defun shr-tag-h6 (cont)
- (shr-heading cont))
-
-(defun shr-tag-hr (cont)
- (shr-ensure-newline)
- (insert (make-string shr-width shr-hr-line) "\n"))
-
-(defun shr-tag-title (cont)
- (shr-heading cont 'bold 'underline))
-
-(defun shr-tag-font (cont)
- (let* ((start (point))
- (color (cdr (assq :color cont)))
- (shr-stylesheet (nconc (list (cons 'color color))
- shr-stylesheet)))
- (shr-generic cont)
- (when color
- (shr-colorize-region start (point) color
- (cdr (assq 'background-color shr-stylesheet))))))
-
-;;; Table rendering algorithm.
-
-;; Table rendering is the only complicated thing here. We do this by
-;; first counting how many TDs there are in each TR, and registering
-;; how wide they think they should be ("width=45%", etc). Then we
-;; render each TD separately (this is done in temporary buffers, so
-;; that we can use all the rendering machinery as if we were in the
-;; main buffer). Now we know how much space each TD really takes, so
-;; we then render everything again with the new widths, and finally
-;; insert all these boxes into the main buffer.
-(defun shr-tag-table-1 (cont)
- (setq cont (or (cdr (assq 'tbody cont))
- cont))
- (let* ((shr-inhibit-images t)
- (shr-table-depth (1+ shr-table-depth))
- (shr-kinsoku-shorten t)
- ;; Find all suggested widths.
- (columns (shr-column-specs cont))
- ;; Compute how many characters wide each TD should be.
- (suggested-widths (shr-pro-rate-columns columns))
- ;; Do a "test rendering" to see how big each TD is (this can
- ;; be smaller (if there's little text) or bigger (if there's
- ;; unbreakable text).
- (sketch (shr-make-table cont suggested-widths))
- ;; Compute the "natural" width by setting each column to 500
- ;; characters and see how wide they really render.
- (natural (shr-make-table cont (make-vector (length columns) 500)))
- (sketch-widths (shr-table-widths sketch natural suggested-widths)))
- ;; This probably won't work very well.
- (when (> (+ (loop for width across sketch-widths
- summing (1+ width))
- shr-indentation 1)
- (frame-width))
- (setq truncate-lines t))
- ;; Then render the table again with these new "hard" widths.
- (shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths)))
-
-(defun shr-tag-table (cont)
- (shr-ensure-paragraph)
- (let* ((caption (cdr (assq 'caption cont)))
- (header (cdr (assq 'thead cont)))
- (body (or (cdr (assq 'tbody cont)) cont))
- (footer (cdr (assq 'tfoot cont)))
- (bgcolor (cdr (assq :bgcolor cont)))
- (start (point))
- (shr-stylesheet (nconc (list (cons 'background-color bgcolor))
- shr-stylesheet))
- (nheader (if header (shr-max-columns header)))
- (nbody (if body (shr-max-columns body)))
- (nfooter (if footer (shr-max-columns footer))))
- (if (and (not caption)
- (not header)
- (not (cdr (assq 'tbody cont)))
- (not (cdr (assq 'tr cont)))
- (not footer))
- ;; The table is totally invalid and just contains random junk.
- ;; Try to output it anyway.
- (shr-generic cont)
- ;; It's a real table, so render it.
- (shr-tag-table-1
- (nconc
- (if caption `((tr (td ,@caption))))
- (if header
- (if footer
- ;; hader + body + footer
- (if (= nheader nbody)
- (if (= nbody nfooter)
- `((tr (td (table (tbody ,@header ,@body ,@footer)))))
- (nconc `((tr (td (table (tbody ,@header ,@body)))))
- (if (= nfooter 1)
- footer
- `((tr (td (table (tbody ,@footer))))))))
- (nconc `((tr (td (table (tbody ,@header)))))
- (if (= nbody nfooter)
- `((tr (td (table (tbody ,@body ,@footer)))))
- (nconc `((tr (td (table (tbody ,@body)))))
- (if (= nfooter 1)
- footer
- `((tr (td (table (tbody ,@footer))))))))))
- ;; header + body
- (if (= nheader nbody)
- `((tr (td (table (tbody ,@header ,@body)))))
- (if (= nheader 1)
- `(,@header (tr (td (table (tbody ,@body)))))
- `((tr (td (table (tbody ,@header))))
- (tr (td (table (tbody ,@body))))))))
- (if footer
- ;; body + footer
- (if (= nbody nfooter)
- `((tr (td (table (tbody ,@body ,@footer)))))
- (nconc `((tr (td (table (tbody ,@body)))))
- (if (= nfooter 1)
- footer
- `((tr (td (table (tbody ,@footer))))))))
- (if caption
- `((tr (td (table (tbody ,@body)))))
- body))))))
- (when bgcolor
- (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
- bgcolor))
- ;; Finally, insert all the images after the table. The Emacs buffer
- ;; model isn't strong enough to allow us to put the images actually
- ;; into the tables.
- (when (zerop shr-table-depth)
- (dolist (elem (shr-find-elements cont 'img))
- (shr-tag-img (cdr elem))))))
-
-(defun shr-find-elements (cont type)
- (let (result)
- (dolist (elem cont)
- (cond ((eq (car elem) type)
- (push elem result))
- ((consp (cdr elem))
- (setq result (nconc (shr-find-elements (cdr elem) type) result)))))
- (nreverse result)))
-
-(defun shr-insert-table (table widths)
- (let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet))
- "collapse"))
- (shr-table-vertical-line (if collapse "" shr-table-vertical-line)))
- (unless collapse
- (shr-insert-table-ruler widths))
- (dolist (row table)
- (let ((start (point))
- (height (let ((max 0))
- (dolist (column row)
- (setq max (max max (cadr column))))
- max)))
- (dotimes (i height)
- (shr-indent)
- (insert shr-table-vertical-line "\n"))
- (dolist (column row)
- (goto-char start)
- (let ((lines (nth 2 column)))
- (dolist (line lines)
- (end-of-line)
- (insert line shr-table-vertical-line)
- (forward-line 1))
- ;; Add blank lines at padding at the bottom of the TD,
- ;; possibly.
- (dotimes (i (- height (length lines)))
- (end-of-line)
- (let ((start (point)))
- (insert (make-string (string-width (car lines)) ? )
- shr-table-vertical-line)
- (when (nth 4 column)
- (shr-add-font start (1- (point))
- (list :background (nth 4 column)))))
- (forward-line 1)))))
- (unless collapse
- (shr-insert-table-ruler widths)))))
-
-(defun shr-insert-table-ruler (widths)
- (when (and (bolp)
- (> shr-indentation 0))
- (shr-indent))
- (insert shr-table-corner)
- (dotimes (i (length widths))
- (insert (make-string (aref widths i) shr-table-horizontal-line)
- shr-table-corner))
- (insert "\n"))
-
-(defun shr-table-widths (table natural-table suggested-widths)
- (let* ((length (length suggested-widths))
- (widths (make-vector length 0))
- (natural-widths (make-vector length 0)))
- (dolist (row table)
- (let ((i 0))
- (dolist (column row)
- (aset widths i (max (aref widths i) column))
- (setq i (1+ i)))))
- (dolist (row natural-table)
- (let ((i 0))
- (dolist (column row)
- (aset natural-widths i (max (aref natural-widths i) column))
- (setq i (1+ i)))))
- (let ((extra (- (apply '+ (append suggested-widths nil))
- (apply '+ (append widths nil))))
- (expanded-columns 0))
- ;; We have extra, unused space, so divide this space amongst the
- ;; columns.
- (when (> extra 0)
- ;; If the natural width is wider than the rendered width, we
- ;; want to allow the column to expand.
- (dotimes (i length)
- (when (> (aref natural-widths i) (aref widths i))
- (setq expanded-columns (1+ expanded-columns))))
- (dotimes (i length)
- (when (> (aref natural-widths i) (aref widths i))
- (aset widths i (min
- (aref natural-widths i)
- (+ (/ extra expanded-columns)
- (aref widths i))))))))
- widths))
-
-(defun shr-make-table (cont widths &optional fill)
- (or (cadr (assoc (list cont widths fill) shr-content-cache))
- (let ((data (shr-make-table-1 cont widths fill)))
- (push (list (list cont widths fill) data)
- shr-content-cache)
- data)))
-
-(defun shr-make-table-1 (cont widths &optional fill)
- (let ((trs nil)
- (shr-inhibit-decoration (not fill)))
- (dolist (row cont)
- (when (eq (car row) 'tr)
- (let ((tds nil)
- (columns (cdr row))
- (i 0)
- column)
- (while (< i (length widths))
- (setq column (pop columns))
- (when (or (memq (car column) '(td th))
- (null column))
- (push (shr-render-td (cdr column) (aref widths i) fill)
- tds)
- (setq i (1+ i))))
- (push (nreverse tds) trs))))
- (nreverse trs)))
-
-(defun shr-render-td (cont width fill)
- (with-temp-buffer
- (let ((bgcolor (cdr (assq :bgcolor cont)))
- (fgcolor (cdr (assq :fgcolor cont)))
- (style (cdr (assq :style cont)))
- (shr-stylesheet shr-stylesheet)
- actual-colors)
- (when style
- (setq style (and (string-match "color" style)
- (shr-parse-style style))))
- (when bgcolor
- (setq style (nconc (list (cons 'background-color bgcolor)) style)))
- (when fgcolor
- (setq style (nconc (list (cons 'color fgcolor)) style)))
- (when style
- (setq shr-stylesheet (append style shr-stylesheet)))
- (let ((shr-width width)
- (shr-indentation 0))
- (shr-descend (cons 'td cont)))
- ;; Delete padding at the bottom of the TDs.
- (delete-region
- (point)
- (progn
- (skip-chars-backward " \t\n")
- (end-of-line)
- (point)))
- (goto-char (point-min))
- (let ((max 0))
- (while (not (eobp))
- (end-of-line)
- (setq max (max max (current-column)))
- (forward-line 1))
- (when fill
- (goto-char (point-min))
- ;; If the buffer is totally empty, then put a single blank
- ;; line here.
- (if (zerop (buffer-size))
- (insert (make-string width ? ))
- ;; Otherwise, fill the buffer.
- (let ((align (cdr (assq :align cont)))
- length)
- (while (not (eobp))
- (end-of-line)
- (setq length (- width (current-column)))
- (when (> length 0)
- (cond
- ((equal align "right")
- (beginning-of-line)
- (insert (make-string length ? )))
- ((equal align "center")
- (insert (make-string (/ length 2) ? ))
- (beginning-of-line)
- (insert (make-string (- length (/ length 2)) ? )))
- (t
- (insert (make-string length ? )))))
- (forward-line 1))))
- (when style
- (setq actual-colors
- (shr-colorize-region
- (point-min) (point-max)
- (cdr (assq 'color shr-stylesheet))
- (cdr (assq 'background-color shr-stylesheet))))))
- (if fill
- (list max
- (count-lines (point-min) (point-max))
- (split-string (buffer-string) "\n")
- nil
- (car actual-colors))
- max)))))
-
-(defun shr-buffer-width ()
- (goto-char (point-min))
- (let ((max 0))
- (while (not (eobp))
- (end-of-line)
- (setq max (max max (current-column)))
- (forward-line 1))
- max))
-
-(defun shr-pro-rate-columns (columns)
- (let ((total-percentage 0)
- (widths (make-vector (length columns) 0)))
- (dotimes (i (length columns))
- (setq total-percentage (+ total-percentage (aref columns i))))
- (setq total-percentage (/ 1.0 total-percentage))
- (dotimes (i (length columns))
- (aset widths i (max (truncate (* (aref columns i)
- total-percentage
- (- shr-width (1+ (length columns)))))
- 10)))
- widths))
-
-;; Return a summary of the number and shape of the TDs in the table.
-(defun shr-column-specs (cont)
- (let ((columns (make-vector (shr-max-columns cont) 1)))
- (dolist (row cont)
- (when (eq (car row) 'tr)
- (let ((i 0))
- (dolist (column (cdr row))
- (when (memq (car column) '(td th))
- (let ((width (cdr (assq :width (cdr column)))))
- (when (and width
- (string-match "\\([0-9]+\\)%" width)
- (not (zerop (setq width (string-to-number
- (match-string 1 width))))))
- (aset columns i (/ width 100.0))))
- (setq i (1+ i)))))))
- columns))
-
-(defun shr-count (cont elem)
- (let ((i 0))
- (dolist (sub cont)
- (when (eq (car sub) elem)
- (setq i (1+ i))))
- i))
-
-(defun shr-max-columns (cont)
- (let ((max 0))
- (dolist (row cont)
- (when (eq (car row) 'tr)
- (setq max (max max (+ (shr-count (cdr row) 'td)
- (shr-count (cdr row) 'th))))))
- max))
-
-;; Emacs less than 24.3
-(unless (fboundp 'add-face-text-property)
- (defun add-face-text-property (beg end face &optional appendp object)
- "Combine FACE BEG and END."
- (let ((b beg))
- (while (< b end)
- (let ((oldval (get-text-property b 'face)))
- (put-text-property
- b (setq b (next-single-property-change b 'face nil end))
- 'face (cond ((null oldval)
- face)
- ((and (consp oldval)
- (not (keywordp (car oldval))))
- (if appendp
- (nconc oldval (list face))
- (cons face oldval)))
- (t
- (if appendp
- (list oldval face)
- (list face oldval))))))))))
-
-(provide 'shr)
-
-;; Local Variables:
-;; coding: utf-8
-;; End:
-
-;;; shr.el ends here
--- /dev/null
+;;; eww.el --- Emacs Web Wowser
+
+;; Copyright (C) 2013 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: html
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'format-spec)
+(require 'shr)
+(require 'url)
+(require 'mm-url)
+
+(defgroup eww nil
+ "Emacs Web Wowser"
+ :version "24.4"
+ :group 'hypermedia
+ :prefix "eww-")
+
+(defcustom eww-header-line-format "%t: %u"
+ "Header line format.
+- %t is replaced by the title.
+- %u is replaced by the URL."
+ :group 'eww
+ :type 'string)
+
+(defface eww-button
+ '((((type x w32 ns) (class color)) ; Like default mode line
+ :box (:line-width 2 :style released-button)
+ :background "lightgrey" :foreground "black"))
+ "Face for eww buffer buttons."
+ :version "24.4"
+ :group 'eww)
+
+(defvar eww-current-url nil)
+(defvar eww-current-title ""
+ "Title of current page.")
+(defvar eww-history nil)
+
+;;;###autoload
+(defun eww (url)
+ "Fetch URL and render the page."
+ (interactive "sUrl: ")
+ (unless (string-match-p "\\`[a-zA-Z][-a-zA-Z0-9+.]*://" url)
+ (setq url (concat "http://" url)))
+ (url-retrieve url 'eww-render (list url)))
+
+(defun eww-render (status url &optional point)
+ (let ((redirect (plist-get status :redirect)))
+ (when redirect
+ (setq url redirect)))
+ (let* ((headers (eww-parse-headers))
+ (shr-target-id
+ (and (string-match "#\\(.*\\)" url)
+ (match-string 1 url)))
+ (content-type
+ (mail-header-parse-content-type
+ (or (cdr (assoc "content-type" headers))
+ "text/plain")))
+ (charset (intern
+ (downcase
+ (or (cdr (assq 'charset (cdr content-type)))
+ (eww-detect-charset (equal (car content-type)
+ "text/html"))
+ "utf8"))))
+ (data-buffer (current-buffer)))
+ (unwind-protect
+ (progn
+ (cond
+ ((equal (car content-type) "text/html")
+ (eww-display-html charset url))
+ ((string-match "^image/" (car content-type))
+ (eww-display-image))
+ (t
+ (eww-display-raw charset)))
+ (cond
+ (point
+ (goto-char point))
+ (shr-target-id
+ (let ((point (next-single-property-change
+ (point-min) 'shr-target-id)))
+ (when point
+ (goto-char (1+ point)))))))
+ (kill-buffer data-buffer))))
+
+(defun eww-parse-headers ()
+ (let ((headers nil))
+ (goto-char (point-min))
+ (while (and (not (eobp))
+ (not (eolp)))
+ (when (looking-at "\\([^:]+\\): *\\(.*\\)")
+ (push (cons (downcase (match-string 1))
+ (match-string 2))
+ headers))
+ (forward-line 1))
+ (unless (eobp)
+ (forward-line 1))
+ headers))
+
+(defun eww-detect-charset (html-p)
+ (let ((case-fold-search t)
+ (pt (point)))
+ (or (and html-p
+ (re-search-forward
+ "<meta[\t\n\r ]+[^>]*charset=\"?\\([^\t\n\r \"/>]+\\)" nil t)
+ (goto-char pt)
+ (match-string 1))
+ (and (looking-at
+ "[\t\n\r ]*<\\?xml[\t\n\r ]+[^>]*encoding=\"\\([^\"]+\\)")
+ (match-string 1)))))
+
+(defun eww-display-html (charset url)
+ (unless (eq charset 'utf8)
+ (decode-coding-region (point) (point-max) charset))
+ (let ((document
+ (list
+ 'base (list (cons 'href url))
+ (libxml-parse-html-region (point) (point-max)))))
+ (eww-setup-buffer)
+ (setq eww-current-url url)
+ (eww-update-header-line-format)
+ (let ((inhibit-read-only t)
+ (shr-width nil)
+ (shr-external-rendering-functions
+ '((title . eww-tag-title)
+ (form . eww-tag-form)
+ (input . eww-tag-input)
+ (textarea . eww-tag-textarea)
+ (body . eww-tag-body)
+ (select . eww-tag-select))))
+ (shr-insert-document document)
+ (eww-convert-widgets))
+ (goto-char (point-min))))
+
+(defun eww-update-header-line-format ()
+ (if eww-header-line-format
+ (setq header-line-format (format-spec eww-header-line-format
+ `((?u . ,eww-current-url)
+ (?t . ,eww-current-title))))
+ (setq header-line-format nil)))
+
+(defun eww-tag-title (cont)
+ (setq eww-current-title "")
+ (dolist (sub cont)
+ (when (eq (car sub) 'text)
+ (setq eww-current-title (concat eww-current-title (cdr sub)))))
+ (eww-update-header-line-format))
+
+(defun eww-tag-body (cont)
+ (let* ((start (point))
+ (fgcolor (cdr (or (assq :fgcolor cont)
+ (assq :text cont))))
+ (bgcolor (cdr (assq :bgcolor cont)))
+ (shr-stylesheet (list (cons 'color fgcolor)
+ (cons 'background-color bgcolor))))
+ (shr-generic cont)
+ (eww-colorize-region start (point) fgcolor bgcolor)))
+
+(defun eww-colorize-region (start end fg &optional bg)
+ (when (or fg bg)
+ (let ((new-colors (shr-color-check fg bg)))
+ (when new-colors
+ (when fg
+ (add-face-text-property start end
+ (list :foreground (cadr new-colors))))
+ (when bg
+ (add-face-text-property start end
+ (list :background (car new-colors))))))))
+
+(defun eww-display-raw (charset)
+ (let ((data (buffer-substring (point) (point-max))))
+ (eww-setup-buffer)
+ (let ((inhibit-read-only t))
+ (insert data))
+ (goto-char (point-min))))
+
+(defun eww-display-image ()
+ (let ((data (buffer-substring (point) (point-max))))
+ (eww-setup-buffer)
+ (let ((inhibit-read-only t))
+ (shr-put-image data nil))
+ (goto-char (point-min))))
+
+(defun eww-setup-buffer ()
+ (pop-to-buffer (get-buffer-create "*eww*"))
+ (remove-overlays)
+ (setq widget-field-list nil)
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (eww-mode))
+
+(defvar eww-mode-map
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map)
+ (define-key map "q" 'eww-quit)
+ (define-key map "g" 'eww-reload)
+ (define-key map [tab] 'shr-next-link)
+ (define-key map [backtab] 'shr-previous-link)
+ (define-key map [delete] 'scroll-down-command)
+ (define-key map "\177" 'scroll-down-command)
+ (define-key map " " 'scroll-up-command)
+ (define-key map "p" 'eww-previous-url)
+ ;;(define-key map "n" 'eww-next-url)
+ map))
+
+(define-derived-mode eww-mode nil "eww"
+ "Mode for browsing the web.
+
+\\{eww-mode-map}"
+ (set (make-local-variable 'eww-current-url) 'author)
+ (set (make-local-variable 'browse-url-browser-function) 'eww-browse-url))
+
+(defun eww-browse-url (url &optional new-window)
+ (push (list eww-current-url (point))
+ eww-history)
+ (eww url))
+
+(defun eww-quit ()
+ "Exit the Emacs Web Wowser."
+ (interactive)
+ (setq eww-history nil)
+ (kill-buffer (current-buffer)))
+
+(defun eww-previous-url ()
+ "Go to the previously displayed page."
+ (interactive)
+ (when (zerop (length eww-history))
+ (error "No previous page"))
+ (let ((prev (pop eww-history)))
+ (url-retrieve (car prev) 'eww-render (list (car prev) (cadr prev)))))
+
+(defun eww-reload ()
+ "Reload the current page."
+ (interactive)
+ (url-retrieve eww-current-url 'eww-render
+ (list eww-current-url (point))))
+
+;; Form support.
+
+(defvar eww-form nil)
+
+(defun eww-tag-form (cont)
+ (let ((eww-form
+ (list (assq :method cont)
+ (assq :action cont)))
+ (start (point)))
+ (shr-ensure-paragraph)
+ (shr-generic cont)
+ (unless (bolp)
+ (insert "\n"))
+ (insert "\n")
+ (when (> (point) start)
+ (put-text-property start (1+ start)
+ 'eww-form eww-form))))
+
+(defun eww-tag-input (cont)
+ (let* ((start (point))
+ (type (downcase (or (cdr (assq :type cont))
+ "text")))
+ (value (cdr (assq :value cont)))
+ (widget
+ (cond
+ ((or (equal type "submit")
+ (equal type "image"))
+ (list 'push-button
+ :notify 'eww-submit
+ :name (cdr (assq :name cont))
+ :value (if (zerop (length value))
+ "Submit"
+ value)
+ :eww-form eww-form
+ (or (if (zerop (length value))
+ "Submit"
+ value))))
+ ((or (equal type "radio")
+ (equal type "checkbox"))
+ (list 'checkbox
+ :notify 'eww-click-radio
+ :name (cdr (assq :name cont))
+ :checkbox-value value
+ :checkbox-type type
+ :eww-form eww-form
+ (cdr (assq :checked cont))))
+ ((equal type "hidden")
+ (list 'hidden
+ :name (cdr (assq :name cont))
+ :value value))
+ (t
+ (list 'editable-field
+ :size (string-to-number
+ (or (cdr (assq :size cont))
+ "40"))
+ :value (or value "")
+ :secret (and (equal type "password") ?*)
+ :action 'eww-submit
+ :name (cdr (assq :name cont))
+ :eww-form eww-form)))))
+ (nconc eww-form (list widget))
+ (unless (eq (car widget) 'hidden)
+ (apply 'widget-create widget)
+ (put-text-property start (point) 'eww-widget widget)
+ (insert " "))))
+
+(defun eww-tag-textarea (cont)
+ (let* ((start (point))
+ (widget
+ (list 'text
+ :size (string-to-number
+ (or (cdr (assq :cols cont))
+ "40"))
+ :value (or (cdr (assq 'text cont)) "")
+ :action 'eww-submit
+ :name (cdr (assq :name cont))
+ :eww-form eww-form)))
+ (nconc eww-form (list widget))
+ (apply 'widget-create widget)
+ (put-text-property start (point) 'eww-widget widget)))
+
+(defun eww-tag-select (cont)
+ (shr-ensure-paragraph)
+ (let ((menu (list 'menu-choice
+ :name (cdr (assq :name cont))
+ :eww-form eww-form))
+ (options nil)
+ (start (point)))
+ (dolist (elem cont)
+ (when (eq (car elem) 'option)
+ (when (cdr (assq :selected (cdr elem)))
+ (nconc menu (list :value
+ (cdr (assq :value (cdr elem))))))
+ (push (list 'item
+ :value (cdr (assq :value (cdr elem)))
+ :tag (cdr (assq 'text (cdr elem))))
+ options)))
+ (when options
+ ;; If we have no selected values, default to the first value.
+ (unless (plist-get (cdr menu) :value)
+ (nconc menu (list :value (nth 2 (car options)))))
+ (nconc menu options)
+ (apply 'widget-create menu)
+ (put-text-property start (point) 'eww-widget menu)
+ (shr-ensure-paragraph))))
+
+(defun eww-click-radio (widget &rest ignore)
+ (let ((form (plist-get (cdr widget) :eww-form))
+ (name (plist-get (cdr widget) :name)))
+ (when (equal (plist-get (cdr widget) :type) "radio")
+ (if (widget-value widget)
+ ;; Switch all the other radio buttons off.
+ (dolist (overlay (overlays-in (point-min) (point-max)))
+ (let ((field (plist-get (overlay-properties overlay) 'button)))
+ (when (and (eq (plist-get (cdr field) :eww-form) form)
+ (equal name (plist-get (cdr field) :name)))
+ (unless (eq field widget)
+ (widget-value-set field nil)))))
+ (widget-value-set widget t)))
+ (eww-fix-widget-keymap)))
+
+(defun eww-submit (widget &rest ignore)
+ (let ((form (plist-get (cdr widget) :eww-form))
+ values)
+ (dolist (overlay (sort (overlays-in (point-min) (point-max))
+ (lambda (o1 o2)
+ (< (overlay-start o1) (overlay-start o2)))))
+ (let ((field (or (plist-get (overlay-properties overlay) 'field)
+ (plist-get (overlay-properties overlay) 'button))))
+ (when (eq (plist-get (cdr field) :eww-form) form)
+ (let ((name (plist-get (cdr field) :name)))
+ (when name
+ (cond
+ ((eq (car field) 'checkbox)
+ (when (widget-value field)
+ (push (cons name (plist-get (cdr field) :checkbox-value))
+ values)))
+ ((eq (car field) 'push-button)
+ ;; We want the values from buttons if we hit a button,
+ ;; if it's the first button in the DOM after the field
+ ;; hit ENTER on.
+ (when (and (eq (car widget) 'push-button)
+ (eq widget field))
+ (push (cons name (widget-value field))
+ values)))
+ (t
+ (push (cons name (widget-value field))
+ values))))))))
+ (dolist (elem form)
+ (when (and (consp elem)
+ (eq (car elem) 'hidden))
+ (push (cons (plist-get (cdr elem) :name)
+ (plist-get (cdr elem) :value))
+ values)))
+ ;; If we hit ENTER in a non-button field, include the value of the
+ ;; first submit button after it.
+ (unless (eq (car widget) 'push-button)
+ (let ((rest form)
+ (name (plist-get (cdr widget) :name)))
+ (when rest
+ (while (and rest
+ (or (not (consp (car rest)))
+ (not (equal name (plist-get (cdar rest) :name)))))
+ (pop rest)))
+ (while rest
+ (let ((elem (pop rest)))
+ (when (and (consp (car rest))
+ (eq (car elem) 'push-button))
+ (push (cons (plist-get (cdr elem) :name)
+ (plist-get (cdr elem) :value))
+ values)
+ (setq rest nil))))))
+ (if (and (stringp (cdr (assq :method form)))
+ (equal (downcase (cdr (assq :method form))) "post"))
+ (let ((url-request-method "POST")
+ (url-request-extra-headers
+ '(("Content-Type" . "application/x-www-form-urlencoded")))
+ (url-request-data (mm-url-encode-www-form-urlencoded values)))
+ (eww-browse-url (shr-expand-url (cdr (assq :action form))
+ eww-current-url)))
+ (eww-browse-url
+ (concat
+ (if (cdr (assq :action form))
+ (shr-expand-url (cdr (assq :action form))
+ eww-current-url)
+ eww-current-url)
+ "?"
+ (mm-url-encode-www-form-urlencoded values))))))
+
+(defun eww-convert-widgets ()
+ (let ((start (point-min))
+ widget)
+ ;; Some widgets come from different buffers (rendered for tables),
+ ;; so we need to nix out the list of widgets and recreate them.
+ (setq widget-field-list nil
+ widget-field-new nil)
+ (while (setq start (if (get-text-property start 'eww-widget)
+ start
+ (next-single-property-change start 'eww-widget)))
+ (setq widget (get-text-property start 'eww-widget))
+ (goto-char start)
+ (let ((end (next-single-property-change start 'eww-widget)))
+ (dolist (overlay (overlays-in start end))
+ (when (or (plist-get (overlay-properties overlay) 'button)
+ (plist-get (overlay-properties overlay) 'field))
+ (delete-overlay overlay)))
+ (delete-region start end))
+ (when (and widget
+ (not (eq (car widget) 'hidden)))
+ (apply 'widget-create widget)
+ (put-text-property start (point) 'help-echo
+ (if (memq (car widget) '(text editable-field))
+ "Input field"
+ "Button"))
+ (when (eq (car widget) 'push-button)
+ (add-face-text-property start (point) 'eww-button t))))
+ (widget-setup)
+ (eww-fix-widget-keymap)))
+
+(defun eww-fix-widget-keymap ()
+ (dolist (overlay (overlays-in (point-min) (point-max)))
+ (when (plist-get (overlay-properties overlay) 'button)
+ (overlay-put overlay 'local-map widget-keymap))))
+
+(provide 'eww)
+
+;;; eww.el ends here
--- /dev/null
+;;; shr-color.el --- Simple HTML Renderer color management
+
+;; Copyright (C) 2010-2013 Free Software Foundation, Inc.
+
+;; Author: Julien Danjou <julien@danjou.info>
+;; Keywords: html
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package handles colors display for shr.
+
+;;; Code:
+
+(require 'color)
+(eval-when-compile (require 'cl))
+
+(defgroup shr-color nil
+ "Simple HTML Renderer colors"
+ :group 'shr)
+
+(defcustom shr-color-visible-luminance-min 40
+ "Minimum luminance distance between two colors to be considered visible.
+Must be between 0 and 100."
+ :group 'shr-color
+ :type 'number)
+
+(defcustom shr-color-visible-distance-min 5
+ "Minimum color distance between two colors to be considered visible.
+This value is used to compare result for `ciede2000'. It's an
+absolute value without any unit."
+ :group 'shr-color
+ :type 'integer)
+
+(defconst shr-color-html-colors-alist
+ '(("AliceBlue" . "#F0F8FF")
+ ("AntiqueWhite" . "#FAEBD7")
+ ("Aqua" . "#00FFFF")
+ ("Aquamarine" . "#7FFFD4")
+ ("Azure" . "#F0FFFF")
+ ("Beige" . "#F5F5DC")
+ ("Bisque" . "#FFE4C4")
+ ("Black" . "#000000")
+ ("BlanchedAlmond" . "#FFEBCD")
+ ("Blue" . "#0000FF")
+ ("BlueViolet" . "#8A2BE2")
+ ("Brown" . "#A52A2A")
+ ("BurlyWood" . "#DEB887")
+ ("CadetBlue" . "#5F9EA0")
+ ("Chartreuse" . "#7FFF00")
+ ("Chocolate" . "#D2691E")
+ ("Coral" . "#FF7F50")
+ ("CornflowerBlue" . "#6495ED")
+ ("Cornsilk" . "#FFF8DC")
+ ("Crimson" . "#DC143C")
+ ("Cyan" . "#00FFFF")
+ ("DarkBlue" . "#00008B")
+ ("DarkCyan" . "#008B8B")
+ ("DarkGoldenRod" . "#B8860B")
+ ("DarkGray" . "#A9A9A9")
+ ("DarkGrey" . "#A9A9A9")
+ ("DarkGreen" . "#006400")
+ ("DarkKhaki" . "#BDB76B")
+ ("DarkMagenta" . "#8B008B")
+ ("DarkOliveGreen" . "#556B2F")
+ ("Darkorange" . "#FF8C00")
+ ("DarkOrchid" . "#9932CC")
+ ("DarkRed" . "#8B0000")
+ ("DarkSalmon" . "#E9967A")
+ ("DarkSeaGreen" . "#8FBC8F")
+ ("DarkSlateBlue" . "#483D8B")
+ ("DarkSlateGray" . "#2F4F4F")
+ ("DarkSlateGrey" . "#2F4F4F")
+ ("DarkTurquoise" . "#00CED1")
+ ("DarkViolet" . "#9400D3")
+ ("DeepPink" . "#FF1493")
+ ("DeepSkyBlue" . "#00BFFF")
+ ("DimGray" . "#696969")
+ ("DimGrey" . "#696969")
+ ("DodgerBlue" . "#1E90FF")
+ ("FireBrick" . "#B22222")
+ ("FloralWhite" . "#FFFAF0")
+ ("ForestGreen" . "#228B22")
+ ("Fuchsia" . "#FF00FF")
+ ("Gainsboro" . "#DCDCDC")
+ ("GhostWhite" . "#F8F8FF")
+ ("Gold" . "#FFD700")
+ ("GoldenRod" . "#DAA520")
+ ("Gray" . "#808080")
+ ("Grey" . "#808080")
+ ("Green" . "#008000")
+ ("GreenYellow" . "#ADFF2F")
+ ("HoneyDew" . "#F0FFF0")
+ ("HotPink" . "#FF69B4")
+ ("IndianRed" . "#CD5C5C")
+ ("Indigo" . "#4B0082")
+ ("Ivory" . "#FFFFF0")
+ ("Khaki" . "#F0E68C")
+ ("Lavender" . "#E6E6FA")
+ ("LavenderBlush" . "#FFF0F5")
+ ("LawnGreen" . "#7CFC00")
+ ("LemonChiffon" . "#FFFACD")
+ ("LightBlue" . "#ADD8E6")
+ ("LightCoral" . "#F08080")
+ ("LightCyan" . "#E0FFFF")
+ ("LightGoldenRodYellow" . "#FAFAD2")
+ ("LightGray" . "#D3D3D3")
+ ("LightGrey" . "#D3D3D3")
+ ("LightGreen" . "#90EE90")
+ ("LightPink" . "#FFB6C1")
+ ("LightSalmon" . "#FFA07A")
+ ("LightSeaGreen" . "#20B2AA")
+ ("LightSkyBlue" . "#87CEFA")
+ ("LightSlateGray" . "#778899")
+ ("LightSlateGrey" . "#778899")
+ ("LightSteelBlue" . "#B0C4DE")
+ ("LightYellow" . "#FFFFE0")
+ ("Lime" . "#00FF00")
+ ("LimeGreen" . "#32CD32")
+ ("Linen" . "#FAF0E6")
+ ("Magenta" . "#FF00FF")
+ ("Maroon" . "#800000")
+ ("MediumAquaMarine" . "#66CDAA")
+ ("MediumBlue" . "#0000CD")
+ ("MediumOrchid" . "#BA55D3")
+ ("MediumPurple" . "#9370D8")
+ ("MediumSeaGreen" . "#3CB371")
+ ("MediumSlateBlue" . "#7B68EE")
+ ("MediumSpringGreen" . "#00FA9A")
+ ("MediumTurquoise" . "#48D1CC")
+ ("MediumVioletRed" . "#C71585")
+ ("MidnightBlue" . "#191970")
+ ("MintCream" . "#F5FFFA")
+ ("MistyRose" . "#FFE4E1")
+ ("Moccasin" . "#FFE4B5")
+ ("NavajoWhite" . "#FFDEAD")
+ ("Navy" . "#000080")
+ ("OldLace" . "#FDF5E6")
+ ("Olive" . "#808000")
+ ("OliveDrab" . "#6B8E23")
+ ("Orange" . "#FFA500")
+ ("OrangeRed" . "#FF4500")
+ ("Orchid" . "#DA70D6")
+ ("PaleGoldenRod" . "#EEE8AA")
+ ("PaleGreen" . "#98FB98")
+ ("PaleTurquoise" . "#AFEEEE")
+ ("PaleVioletRed" . "#D87093")
+ ("PapayaWhip" . "#FFEFD5")
+ ("PeachPuff" . "#FFDAB9")
+ ("Peru" . "#CD853F")
+ ("Pink" . "#FFC0CB")
+ ("Plum" . "#DDA0DD")
+ ("PowderBlue" . "#B0E0E6")
+ ("Purple" . "#800080")
+ ("Red" . "#FF0000")
+ ("RosyBrown" . "#BC8F8F")
+ ("RoyalBlue" . "#4169E1")
+ ("SaddleBrown" . "#8B4513")
+ ("Salmon" . "#FA8072")
+ ("SandyBrown" . "#F4A460")
+ ("SeaGreen" . "#2E8B57")
+ ("SeaShell" . "#FFF5EE")
+ ("Sienna" . "#A0522D")
+ ("Silver" . "#C0C0C0")
+ ("SkyBlue" . "#87CEEB")
+ ("SlateBlue" . "#6A5ACD")
+ ("SlateGray" . "#708090")
+ ("SlateGrey" . "#708090")
+ ("Snow" . "#FFFAFA")
+ ("SpringGreen" . "#00FF7F")
+ ("SteelBlue" . "#4682B4")
+ ("Tan" . "#D2B48C")
+ ("Teal" . "#008080")
+ ("Thistle" . "#D8BFD8")
+ ("Tomato" . "#FF6347")
+ ("Turquoise" . "#40E0D0")
+ ("Violet" . "#EE82EE")
+ ("Wheat" . "#F5DEB3")
+ ("White" . "#FFFFFF")
+ ("WhiteSmoke" . "#F5F5F5")
+ ("Yellow" . "#FFFF00")
+ ("YellowGreen" . "#9ACD32"))
+ "Alist of HTML colors.
+Each entry should have the form (COLOR-NAME . HEXADECIMAL-COLOR).")
+
+(defun shr-color-relative-to-absolute (number)
+ "Convert a relative NUMBER to absolute.
+If NUMBER is absolute, return NUMBER.
+This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"."
+ (let ((string-length (- (length number) 1)))
+ ;; Is this a number with %?
+ (if (eq (elt number string-length) ?%)
+ (/ (* (string-to-number (substring number 0 string-length)) 255) 100)
+ (string-to-number number))))
+
+(defun shr-color-hue-to-rgb (x y h)
+ "Convert X Y H to RGB value."
+ (when (< h 0) (incf h))
+ (when (> h 1) (decf h))
+ (cond ((< h (/ 1 6.0)) (+ x (* (- y x) h 6)))
+ ((< h 0.5) y)
+ ((< h (/ 2.0 3.0)) (+ x (* (- y x) (- (/ 2.0 3.0) h) 6)))
+ (t x)))
+
+(defun shr-color-hsl-to-rgb-fractions (h s l)
+ "Convert H S L to fractional RGB values."
+ (let (m1 m2)
+ (if (<= l 0.5)
+ (setq m2 (* l (+ s 1)))
+ (setq m2 (- (+ l s) (* l s))))
+ (setq m1 (- (* l 2) m2))
+ (list (shr-color-hue-to-rgb m1 m2 (+ h (/ 1 3.0)))
+ (shr-color-hue-to-rgb m1 m2 h)
+ (shr-color-hue-to-rgb m1 m2 (- h (/ 1 3.0))))))
+
+(defun shr-color->hexadecimal (color)
+ "Convert any color format to hexadecimal representation.
+Like rgb() or hsl()."
+ (when color
+ (cond
+ ;; Hexadecimal color: #abc or #aabbcc
+ ((string-match
+ "\\(#[0-9a-fA-F]\\{3\\}[0-9a-fA-F]\\{3\\}?\\)"
+ color)
+ (match-string 1 color))
+ ;; rgb() or rgba() colors
+ ((or (string-match
+ "rgb(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*)"
+ color)
+ (string-match
+ "rgba(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)"
+ color))
+ (format "#%02X%02X%02X"
+ (shr-color-relative-to-absolute (match-string-no-properties 1 color))
+ (shr-color-relative-to-absolute (match-string-no-properties 2 color))
+ (shr-color-relative-to-absolute (match-string-no-properties 3 color))))
+ ;; hsl() or hsla() colors
+ ((or (string-match
+ "hsl(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*)"
+ color)
+ (string-match
+ "hsla(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)"
+ color))
+ (let ((h (/ (string-to-number (match-string-no-properties 1 color)) 360.0))
+ (s (/ (string-to-number (match-string-no-properties 2 color)) 100.0))
+ (l (/ (string-to-number (match-string-no-properties 3 color)) 100.0)))
+ (destructuring-bind (r g b)
+ (shr-color-hsl-to-rgb-fractions h s l)
+ (color-rgb-to-hex r g b))))
+ ;; Color names
+ ((cdr (assoc-string color shr-color-html-colors-alist t)))
+ ;; Unrecognized color :(
+ (t
+ nil))))
+
+(defun shr-color-set-minimum-interval (val1 val2 min max interval
+ &optional fixed)
+ "Set minimum interval between VAL1 and VAL2 to INTERVAL.
+The values are bound by MIN and MAX.
+If FIXED is t, then VAL1 will not be touched."
+ (let ((diff (abs (- val1 val2))))
+ (unless (>= diff interval)
+ (if fixed
+ (let* ((missing (- interval diff))
+ ;; If val2 > val1, try to increase val2
+ ;; That's the "good direction"
+ (val2-good-direction
+ (if (> val2 val1)
+ (min max (+ val2 missing))
+ (max min (- val2 missing))))
+ (diff-val2-good-direction-val1 (abs (- val2-good-direction val1))))
+ (if (>= diff-val2-good-direction-val1 interval)
+ (setq val2 val2-good-direction)
+ ;; Good-direction is not so good, compute bad-direction
+ (let* ((val2-bad-direction
+ (if (> val2 val1)
+ (max min (- val1 interval))
+ (min max (+ val1 interval))))
+ (diff-val2-bad-direction-val1 (abs (- val2-bad-direction val1))))
+ (if (>= diff-val2-bad-direction-val1 interval)
+ (setq val2 val2-bad-direction)
+ ;; Still not good, pick the best and prefer good direction
+ (setq val2
+ (if (>= diff-val2-good-direction-val1 diff-val2-bad-direction-val1)
+ val2-good-direction
+ val2-bad-direction))))))
+ ;; No fixed, move val1 and val2
+ (let ((missing (/ (- interval diff) 2.0)))
+ (if (< val1 val2)
+ (setq val1 (max min (- val1 missing))
+ val2 (min max (+ val2 missing)))
+ (setq val2 (max min (- val2 missing))
+ val1 (min max (+ val1 missing))))
+ (setq diff (abs (- val1 val2))) ; Recompute diff
+ (unless (>= diff interval)
+ ;; Not ok, we hit a boundary
+ (let ((missing (- interval diff)))
+ (cond ((= val1 min)
+ (setq val2 (+ val2 missing)))
+ ((= val2 min)
+ (setq val1 (+ val1 missing)))
+ ((= val1 max)
+ (setq val2 (- val2 missing)))
+ ((= val2 max)
+ (setq val1 (- val1 missing)))))))))
+ (list val1 val2)))
+
+(defun shr-color-visible (bg fg &optional fixed-background)
+ "Check that BG and FG colors are visible if they are drawn on each other.
+Return (bg fg) if they are. If they are too similar, two new
+colors are returned instead.
+If FIXED-BACKGROUND is set, and if the color are not visible, a
+new background color will not be computed. Only the foreground
+color will be adapted to be visible on BG."
+ ;; Convert fg and bg to CIE Lab
+ (let ((fg-norm (color-name-to-rgb fg))
+ (bg-norm (color-name-to-rgb bg)))
+ (if (or (null fg-norm)
+ (null bg-norm))
+ (list bg fg)
+ (let* ((fg-lab (apply 'color-srgb-to-lab fg-norm))
+ (bg-lab (apply 'color-srgb-to-lab bg-norm))
+ ;; Compute color distance using CIE DE 2000
+ (fg-bg-distance (color-cie-de2000 fg-lab bg-lab))
+ ;; Compute luminance distance (subtract L component)
+ (luminance-distance (abs (- (car fg-lab) (car bg-lab)))))
+ (if (and (>= fg-bg-distance shr-color-visible-distance-min)
+ (>= luminance-distance shr-color-visible-luminance-min))
+ (list bg fg)
+ ;; Not visible, try to change luminance to make them visible
+ (let ((Ls (shr-color-set-minimum-interval
+ (car bg-lab) (car fg-lab) 0 100
+ shr-color-visible-luminance-min fixed-background)))
+ (unless fixed-background
+ (setcar bg-lab (car Ls)))
+ (setcar fg-lab (cadr Ls))
+ (list
+ (if fixed-background
+ bg
+ (apply 'format "#%02x%02x%02x"
+ (mapcar (lambda (x) (* (max (min 1 x) 0) 255))
+ (apply 'color-lab-to-srgb bg-lab))))
+ (apply 'format "#%02x%02x%02x"
+ (mapcar (lambda (x) (* (max (min 1 x) 0) 255))
+ (apply 'color-lab-to-srgb fg-lab))))))))))
+
+(provide 'shr-color)
+
+;;; shr-color.el ends here
--- /dev/null
+;;; shr.el --- Simple HTML Renderer
+
+;; Copyright (C) 2010-2013 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: html
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package takes a HTML parse tree (as provided by
+;; libxml-parse-html-region) and renders it in the current buffer. It
+;; does not do CSS, JavaScript or anything advanced: It's geared
+;; towards rendering typical short snippets of HTML, like what you'd
+;; find in HTML email and the like.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(eval-when-compile (require 'url)) ;For url-filename's setf handler.
+(require 'browse-url)
+
+(defgroup shr nil
+ "Simple HTML Renderer"
+ :version "24.1"
+ :group 'mail)
+
+(defcustom shr-max-image-proportion 0.9
+ "How big pictures displayed are in relation to the window they're in.
+A value of 0.7 means that they are allowed to take up 70% of the
+width and height of the window. If they are larger than this,
+and Emacs supports it, then the images will be rescaled down to
+fit these criteria."
+ :version "24.1"
+ :group 'shr
+ :type 'float)
+
+(defcustom shr-blocked-images nil
+ "Images that have URLs matching this regexp will be blocked."
+ :version "24.1"
+ :group 'shr
+ :type '(choice (const nil) regexp))
+
+(defcustom shr-table-horizontal-line ?\s
+ "Character used to draw horizontal table lines."
+ :group 'shr
+ :type 'character)
+
+(defcustom shr-table-vertical-line ?\s
+ "Character used to draw vertical table lines."
+ :group 'shr
+ :type 'character)
+
+(defcustom shr-table-corner ?\s
+ "Character used to draw table corners."
+ :group 'shr
+ :type 'character)
+
+(defcustom shr-hr-line ?-
+ "Character used to draw hr lines."
+ :group 'shr
+ :type 'character)
+
+(defcustom shr-width fill-column
+ "Frame width to use for rendering.
+May either be an integer specifying a fixed width in characters,
+or nil, meaning that the full width of the window should be
+used."
+ :type '(choice (integer :tag "Fixed width in characters")
+ (const :tag "Use the width of the window" nil))
+ :group 'shr)
+
+(defcustom shr-bullet "* "
+ "Bullet used for unordered lists.
+Alternative suggestions are:
+- \" \"
+- \" \""
+ :type 'string
+ :group 'shr)
+
+(defvar shr-content-function nil
+ "If bound, this should be a function that will return the content.
+This is used for cid: URLs, and the function is called with the
+cid: URL as the argument.")
+
+(defvar shr-put-image-function 'shr-put-image
+ "Function called to put image and alt string.")
+
+(defface shr-strike-through '((t (:strike-through t)))
+ "Font for <s> elements."
+ :group 'shr)
+
+(defface shr-link
+ '((t (:inherit link)))
+ "Font for link elements."
+ :group 'shr)
+
+;;; Internal variables.
+
+(defvar shr-folding-mode nil)
+(defvar shr-state nil)
+(defvar shr-start nil)
+(defvar shr-indentation 0)
+(defvar shr-inhibit-images nil)
+(defvar shr-list-mode nil)
+(defvar shr-content-cache nil)
+(defvar shr-kinsoku-shorten nil)
+(defvar shr-table-depth 0)
+(defvar shr-stylesheet nil)
+(defvar shr-base nil)
+(defvar shr-ignore-cache nil)
+(defvar shr-external-rendering-functions nil)
+(defvar shr-target-id nil)
+(defvar shr-inhibit-decoration nil)
+
+(defvar shr-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "a" 'shr-show-alt-text)
+ (define-key map "i" 'shr-browse-image)
+ (define-key map "z" 'shr-zoom-image)
+ (define-key map [tab] 'shr-next-link)
+ (define-key map [backtab] 'shr-previous-link)
+ (define-key map "I" 'shr-insert-image)
+ (define-key map "u" 'shr-copy-url)
+ (define-key map "v" 'shr-browse-url)
+ (define-key map "o" 'shr-save-contents)
+ (define-key map "\r" 'shr-browse-url)
+ map))
+
+;; Public functions and commands.
+(declare-function libxml-parse-html-region "xml.c"
+ (start end &optional base-url))
+
+(defun shr-render-buffer (buffer)
+ "Display the HTML rendering of the current buffer."
+ (interactive (list (current-buffer)))
+ (or (fboundp 'libxml-parse-html-region)
+ (error "This function requires Emacs to be compiled with libxml2"))
+ (pop-to-buffer "*html*")
+ (erase-buffer)
+ (shr-insert-document
+ (with-current-buffer buffer
+ (libxml-parse-html-region (point-min) (point-max))))
+ (goto-char (point-min)))
+
+(defun shr-visit-file (file)
+ "Parse FILE as an HTML document, and render it in a new buffer."
+ (interactive "fHTML file name: ")
+ (with-temp-buffer
+ (insert-file-contents file)
+ (shr-render-buffer (current-buffer))))
+
+;;;###autoload
+(defun shr-insert-document (dom)
+ "Render the parsed document DOM into the current buffer.
+DOM should be a parse tree as generated by
+`libxml-parse-html-region' or similar."
+ (setq shr-content-cache nil)
+ (let ((start (point))
+ (shr-state nil)
+ (shr-start nil)
+ (shr-base nil)
+ (shr-preliminary-table-render 0)
+ (shr-width (or shr-width (window-width))))
+ (shr-descend (shr-transform-dom dom))
+ (shr-remove-trailing-whitespace start (point))))
+
+(defun shr-remove-trailing-whitespace (start end)
+ (let ((width (window-width)))
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char start)
+ (while (not (eobp))
+ (end-of-line)
+ (when (> (shr-previous-newline-padding-width (current-column)) width)
+ (dolist (overlay (overlays-at (point)))
+ (when (overlay-get overlay 'before-string)
+ (overlay-put overlay 'before-string nil))))
+ (forward-line 1)))))
+
+(defun shr-copy-url ()
+ "Copy the URL under point to the kill ring.
+If called twice, then try to fetch the URL and see whether it
+redirects somewhere else."
+ (interactive)
+ (let ((url (get-text-property (point) 'shr-url)))
+ (cond
+ ((not url)
+ (message "No URL under point"))
+ ;; Resolve redirected URLs.
+ ((equal url (car kill-ring))
+ (url-retrieve
+ url
+ (lambda (a)
+ (when (and (consp a)
+ (eq (car a) :redirect))
+ (with-temp-buffer
+ (insert (cadr a))
+ (goto-char (point-min))
+ ;; Remove common tracking junk from the URL.
+ (when (re-search-forward ".utm_.*" nil t)
+ (replace-match "" t t))
+ (message "Copied %s" (buffer-string))
+ (copy-region-as-kill (point-min) (point-max)))))
+ nil t))
+ ;; Copy the URL to the kill ring.
+ (t
+ (with-temp-buffer
+ (insert url)
+ (copy-region-as-kill (point-min) (point-max))
+ (message "Copied %s" url))))))
+
+(defun shr-next-link ()
+ "Skip to the next link."
+ (interactive)
+ (let ((skip (text-property-any (point) (point-max) 'help-echo nil)))
+ (if (not (setq skip (text-property-not-all skip (point-max)
+ 'help-echo nil)))
+ (message "No next link")
+ (goto-char skip)
+ (message "%s" (get-text-property (point) 'help-echo)))))
+
+(defun shr-previous-link ()
+ "Skip to the previous link."
+ (interactive)
+ (let ((start (point))
+ (found nil))
+ ;; Skip past the current link.
+ (while (and (not (bobp))
+ (get-text-property (point) 'help-echo))
+ (forward-char -1))
+ ;; Find the previous link.
+ (while (and (not (bobp))
+ (not (setq found (get-text-property (point) 'help-echo))))
+ (forward-char -1))
+ (if (not found)
+ (progn
+ (message "No previous link")
+ (goto-char start))
+ ;; Put point at the start of the link.
+ (while (and (not (bobp))
+ (get-text-property (point) 'help-echo))
+ (forward-char -1))
+ (forward-char 1)
+ (message "%s" (get-text-property (point) 'help-echo)))))
+
+(defun shr-show-alt-text ()
+ "Show the ALT text of the image under point."
+ (interactive)
+ (let ((text (get-text-property (point) 'shr-alt)))
+ (if (not text)
+ (message "No image under point")
+ (message "%s" text))))
+
+(defun shr-browse-image (&optional copy-url)
+ "Browse the image under point.
+If COPY-URL (the prefix if called interactively) is non-nil, copy
+the URL of the image to the kill buffer instead."
+ (interactive "P")
+ (let ((url (get-text-property (point) 'image-url)))
+ (cond
+ ((not url)
+ (message "No image under point"))
+ (copy-url
+ (with-temp-buffer
+ (insert url)
+ (copy-region-as-kill (point-min) (point-max))
+ (message "Copied %s" url)))
+ (t
+ (message "Browsing %s..." url)
+ (browse-url url)))))
+
+(defun shr-insert-image ()
+ "Insert the image under point into the buffer."
+ (interactive)
+ (let ((url (get-text-property (point) 'image-url)))
+ (if (not url)
+ (message "No image under point")
+ (message "Inserting %s..." url)
+ (url-retrieve url 'shr-image-fetched
+ (list (current-buffer) (1- (point)) (point-marker))
+ t t))))
+
+(defun shr-zoom-image ()
+ "Toggle the image size.
+The size will be rotated between the default size, the original
+size, and full-buffer size."
+ (interactive)
+ (let ((url (get-text-property (point) 'image-url))
+ (size (get-text-property (point) 'image-size))
+ (buffer-read-only nil))
+ (if (not url)
+ (message "No image under point")
+ ;; Delete the old picture.
+ (while (get-text-property (point) 'image-url)
+ (forward-char -1))
+ (forward-char 1)
+ (let ((start (point)))
+ (while (get-text-property (point) 'image-url)
+ (forward-char 1))
+ (forward-char -1)
+ (put-text-property start (point) 'display nil)
+ (when (> (- (point) start) 2)
+ (delete-region start (1- (point)))))
+ (message "Inserting %s..." url)
+ (url-retrieve url 'shr-image-fetched
+ (list (current-buffer) (1- (point)) (point-marker)
+ (list (cons 'size
+ (cond ((or (eq size 'default)
+ (null size))
+ 'original)
+ ((eq size 'original)
+ 'full)
+ ((eq size 'full)
+ 'default)))))
+ t))))
+
+;;; Utility functions.
+
+(defun shr-transform-dom (dom)
+ (let ((result (list (pop dom))))
+ (dolist (arg (pop dom))
+ (push (cons (intern (concat ":" (symbol-name (car arg))) obarray)
+ (cdr arg))
+ result))
+ (dolist (sub dom)
+ (if (stringp sub)
+ (push (cons 'text sub) result)
+ (push (shr-transform-dom sub) result)))
+ (nreverse result)))
+
+(defun shr-descend (dom)
+ (let ((function
+ (or
+ ;; Allow other packages to override (or provide) rendering
+ ;; of elements.
+ (cdr (assq (car dom) shr-external-rendering-functions))
+ (intern (concat "shr-tag-" (symbol-name (car dom))) obarray)))
+ (style (cdr (assq :style (cdr dom))))
+ (shr-stylesheet shr-stylesheet)
+ (start (point)))
+ (when style
+ (if (string-match "color\\|display\\|border-collapse" style)
+ (setq shr-stylesheet (nconc (shr-parse-style style)
+ shr-stylesheet))
+ (setq style nil)))
+ ;; If we have a display:none, then just ignore this part of the
+ ;; DOM.
+ (unless (equal (cdr (assq 'display shr-stylesheet)) "none")
+ (if (fboundp function)
+ (funcall function (cdr dom))
+ (shr-generic (cdr dom)))
+ (when (and shr-target-id
+ (equal (cdr (assq :id (cdr dom))) shr-target-id))
+ (put-text-property start (1+ start) 'shr-target-id shr-target-id))
+ ;; If style is set, then this node has set the color.
+ (when style
+ (shr-colorize-region start (point)
+ (cdr (assq 'color shr-stylesheet))
+ (cdr (assq 'background-color shr-stylesheet)))))))
+
+(defun shr-generic (cont)
+ (dolist (sub cont)
+ (cond
+ ((eq (car sub) 'text)
+ (shr-insert (cdr sub)))
+ ((listp (cdr sub))
+ (shr-descend sub)))))
+
+(defmacro shr-char-breakable-p (char)
+ "Return non-nil if a line can be broken before and after CHAR."
+ `(aref fill-find-break-point-function-table ,char))
+(defmacro shr-char-nospace-p (char)
+ "Return non-nil if no space is required before and after CHAR."
+ `(aref fill-nospace-between-words-table ,char))
+
+;; KINSOKU is a Japanese word meaning a rule that should not be violated.
+;; In Emacs, it is a term used for characters, e.g. punctuation marks,
+;; parentheses, and so on, that should not be placed in the beginning
+;; of a line or the end of a line.
+(defmacro shr-char-kinsoku-bol-p (char)
+ "Return non-nil if a line ought not to begin with CHAR."
+ `(aref (char-category-set ,char) ?>))
+(defmacro shr-char-kinsoku-eol-p (char)
+ "Return non-nil if a line ought not to end with CHAR."
+ `(aref (char-category-set ,char) ?<))
+(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
+ (load "kinsoku" nil t))
+
+(defun shr-insert (text)
+ (when (and (eq shr-state 'image)
+ (not (bolp))
+ (not (string-match "\\`[ \t\n]+\\'" text)))
+ (insert "\n")
+ (setq shr-state nil))
+ (cond
+ ((eq shr-folding-mode 'none)
+ (insert text))
+ (t
+ (when (and (string-match "\\`[ \t\n ]" text)
+ (not (bolp))
+ (not (eq (char-after (1- (point))) ? )))
+ (insert " "))
+ (dolist (elem (split-string text "[ \f\t\n\r\v ]+" t))
+ (when (and (bolp)
+ (> shr-indentation 0))
+ (shr-indent))
+ ;; No space is needed behind a wide character categorized as
+ ;; kinsoku-bol, between characters both categorized as nospace,
+ ;; or at the beginning of a line.
+ (let (prev)
+ (when (and (> (current-column) shr-indentation)
+ (eq (preceding-char) ? )
+ (or (= (line-beginning-position) (1- (point)))
+ (and (shr-char-breakable-p
+ (setq prev (char-after (- (point) 2))))
+ (shr-char-kinsoku-bol-p prev))
+ (and (shr-char-nospace-p prev)
+ (shr-char-nospace-p (aref elem 0)))))
+ (delete-char -1)))
+ ;; The shr-start is a special variable that is used to pass
+ ;; upwards the first point in the buffer where the text really
+ ;; starts.
+ (unless shr-start
+ (setq shr-start (point)))
+ (insert elem)
+ (setq shr-state nil)
+ (let (found)
+ (while (and (> (current-column) shr-width)
+ (progn
+ (setq found (shr-find-fill-point))
+ (not (eolp))))
+ (when (eq (preceding-char) ? )
+ (delete-char -1))
+ (insert "\n")
+ (unless found
+ ;; No space is needed at the beginning of a line.
+ (when (eq (following-char) ? )
+ (delete-char 1)))
+ (when (> shr-indentation 0)
+ (shr-indent))
+ (end-of-line))
+ (insert " ")))
+ (unless (string-match "[ \t\r\n ]\\'" text)
+ (delete-char -1)))))
+
+(defun shr-find-fill-point ()
+ (when (> (move-to-column shr-width) shr-width)
+ (backward-char 1))
+ (let ((bp (point))
+ failed)
+ (while (not (or (setq failed (= (current-column) shr-indentation))
+ (eq (preceding-char) ? )
+ (eq (following-char) ? )
+ (shr-char-breakable-p (preceding-char))
+ (shr-char-breakable-p (following-char))
+ (if (eq (preceding-char) ?')
+ (not (memq (char-after (- (point) 2))
+ (list nil ?\n ? )))
+ (and (shr-char-kinsoku-bol-p (preceding-char))
+ (shr-char-breakable-p (following-char))
+ (not (shr-char-kinsoku-bol-p (following-char)))))
+ (shr-char-kinsoku-eol-p (following-char))))
+ (backward-char 1))
+ (if (and (not (or failed (eolp)))
+ (eq (preceding-char) ?'))
+ (while (not (or (setq failed (eolp))
+ (eq (following-char) ? )
+ (shr-char-breakable-p (following-char))
+ (shr-char-kinsoku-eol-p (following-char))))
+ (forward-char 1)))
+ (if failed
+ ;; There's no breakable point, so we give it up.
+ (let (found)
+ (goto-char bp)
+ (unless shr-kinsoku-shorten
+ (while (and (setq found (re-search-forward
+ "\\(\\c>\\)\\| \\|\\c<\\|\\c|"
+ (line-end-position) 'move))
+ (eq (preceding-char) ?')))
+ (if (and found (not (match-beginning 1)))
+ (goto-char (match-beginning 0)))))
+ (or
+ (eolp)
+ ;; Don't put kinsoku-bol characters at the beginning of a line,
+ ;; or kinsoku-eol characters at the end of a line.
+ (cond
+ (shr-kinsoku-shorten
+ (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
+ (shr-char-kinsoku-eol-p (preceding-char)))
+ (backward-char 1))
+ (when (setq failed (= (current-column) shr-indentation))
+ ;; There's no breakable point that doesn't violate kinsoku,
+ ;; so we look for the second best position.
+ (while (and (progn
+ (forward-char 1)
+ (<= (current-column) shr-width))
+ (progn
+ (setq bp (point))
+ (shr-char-kinsoku-eol-p (following-char)))))
+ (goto-char bp)))
+ ((shr-char-kinsoku-eol-p (preceding-char))
+ ;; Find backward the point where kinsoku-eol characters begin.
+ (let ((count 4))
+ (while
+ (progn
+ (backward-char 1)
+ (and (> (setq count (1- count)) 0)
+ (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
+ (or (shr-char-kinsoku-eol-p (preceding-char))
+ (shr-char-kinsoku-bol-p (following-char)))))))
+ (if (setq failed (= (current-column) shr-indentation))
+ ;; There's no breakable point that doesn't violate kinsoku,
+ ;; so we go to the second best position.
+ (if (looking-at "\\(\\c<+\\)\\c<")
+ (goto-char (match-end 1))
+ (forward-char 1))))
+ ((shr-char-kinsoku-bol-p (following-char))
+ ;; Find forward the point where kinsoku-bol characters end.
+ (let ((count 4))
+ (while (progn
+ (forward-char 1)
+ (and (>= (setq count (1- count)) 0)
+ (shr-char-kinsoku-bol-p (following-char))
+ (shr-char-breakable-p (following-char))))))))
+ (when (eq (following-char) ? )
+ (forward-char 1))))
+ (not failed)))
+
+(defun shr-parse-base (url)
+ ;; Always chop off anchors.
+ (when (string-match "#.*" url)
+ (setq url (substring url 0 (match-beginning 0))))
+ (let* ((parsed (url-generic-parse-url url))
+ (local (url-filename parsed)))
+ (setf (url-filename parsed) "")
+ ;; Chop off the bit after the last slash.
+ (when (string-match "\\`\\(.*/\\)[^/]+\\'" local)
+ (setq local (match-string 1 local)))
+ ;; Always make the local bit end with a slash.
+ (when (and (not (zerop (length local)))
+ (not (eq (aref local (1- (length local))) ?/)))
+ (setq local (concat local "/")))
+ (list (url-recreate-url parsed)
+ local
+ (url-type parsed)
+ url)))
+
+(defun shr-expand-url (url &optional base)
+ (setq base
+ (if base
+ (shr-parse-base base)
+ ;; Bound by the parser.
+ shr-base))
+ (when (zerop (length url))
+ (setq url nil))
+ (cond ((or (not url)
+ (not base)
+ (string-match "\\`[a-z]*:" url))
+ ;; Absolute URL.
+ (or url (car base)))
+ ((eq (aref url 0) ?/)
+ (if (and (> (length url) 1)
+ (eq (aref url 1) ?/))
+ ;; //host...; just use the protocol
+ (concat (nth 2 base) ":" url)
+ ;; Just use the host name part.
+ (concat (car base) url)))
+ ((eq (aref url 0) ?#)
+ ;; A link to an anchor.
+ (concat (nth 3 base) url))
+ (t
+ ;; Totally relative.
+ (concat (car base) (cadr base) url))))
+
+(defun shr-ensure-newline ()
+ (unless (zerop (current-column))
+ (insert "\n")))
+
+(defun shr-ensure-paragraph ()
+ (unless (bobp)
+ (if (<= (current-column) shr-indentation)
+ (unless (save-excursion
+ (forward-line -1)
+ (looking-at " *$"))
+ (insert "\n"))
+ (if (save-excursion
+ (beginning-of-line)
+ ;; If the current line is totally blank, and doesn't even
+ ;; have any face properties set, then delete the blank
+ ;; space.
+ (and (looking-at " *$")
+ (not (get-text-property (point) 'face))
+ (not (= (next-single-property-change (point) 'face nil
+ (line-end-position))
+ (line-end-position)))))
+ (delete-region (match-beginning 0) (match-end 0))
+ (insert "\n\n")))))
+
+(defun shr-indent ()
+ (when (> shr-indentation 0)
+ (insert (make-string shr-indentation ? ))))
+
+(defun shr-fontize-cont (cont &rest types)
+ (let (shr-start)
+ (shr-generic cont)
+ (dolist (type types)
+ (shr-add-font (or shr-start (point)) (point) type))))
+
+;; Add face to the region, but avoid putting the font properties on
+;; blank text at the start of the line, and the newline at the end, to
+;; avoid ugliness.
+(defun shr-add-font (start end type)
+ (unless shr-inhibit-decoration
+ (save-excursion
+ (goto-char start)
+ (while (< (point) end)
+ (when (bolp)
+ (skip-chars-forward " "))
+ (add-face-text-property (point) (min (line-end-position) end) type t)
+ (if (< (line-end-position) end)
+ (forward-line 1)
+ (goto-char end))))))
+
+(defun shr-browse-url ()
+ "Browse the URL under point."
+ (interactive)
+ (let ((url (get-text-property (point) 'shr-url)))
+ (cond
+ ((not url)
+ (message "No link under point"))
+ ((string-match "^mailto:" url)
+ (browse-url-mail url))
+ (t
+ (browse-url url)))))
+
+(defun shr-save-contents (directory)
+ "Save the contents from URL in a file."
+ (interactive "DSave contents of URL to directory: ")
+ (let ((url (get-text-property (point) 'shr-url)))
+ (if (not url)
+ (message "No link under point")
+ (url-retrieve (shr-encode-url url)
+ 'shr-store-contents (list url directory)
+ nil t))))
+
+(defun shr-store-contents (status url directory)
+ (unless (plist-get status :error)
+ (when (or (search-forward "\n\n" nil t)
+ (search-forward "\r\n\r\n" nil t))
+ (write-region (point) (point-max)
+ (expand-file-name (file-name-nondirectory url)
+ directory)))))
+
+(defun shr-image-fetched (status buffer start end &optional flags)
+ (let ((image-buffer (current-buffer)))
+ (when (and (buffer-name buffer)
+ (not (plist-get status :error)))
+ (url-store-in-cache image-buffer)
+ (when (or (search-forward "\n\n" nil t)
+ (search-forward "\r\n\r\n" nil t))
+ (let ((data (buffer-substring (point) (point-max))))
+ (with-current-buffer buffer
+ (save-excursion
+ (let ((alt (buffer-substring start end))
+ (properties (text-properties-at start))
+ (inhibit-read-only t))
+ (delete-region start end)
+ (goto-char start)
+ (funcall shr-put-image-function data alt flags)
+ (while properties
+ (let ((type (pop properties))
+ (value (pop properties)))
+ (unless (memq type '(display image-size))
+ (put-text-property start (point) type value))))))))))
+ (kill-buffer image-buffer)))
+
+(defun shr-image-from-data (data)
+ "Return an image from the data: URI content DATA."
+ (when (string-match
+ "\\(\\([^/;,]+\\(/[^;,]+\\)?\\)\\(;[^;,]+\\)*\\)?,\\(.*\\)"
+ data)
+ (let ((param (match-string 4 data))
+ (payload (url-unhex-string (match-string 5 data))))
+ (when (string-match "^.*\\(;[ \t]*base64\\)$" param)
+ (setq payload (base64-decode-string payload)))
+ payload)))
+
+(defun shr-put-image (data alt &optional flags)
+ "Put image DATA with a string ALT. Return image."
+ (if (display-graphic-p)
+ (let* ((size (cdr (assq 'size flags)))
+ (start (point))
+ (image (cond
+ ((eq size 'original)
+ (create-image data nil t :ascent 100))
+ ((eq size 'full)
+ (ignore-errors
+ (shr-rescale-image data t)))
+ (t
+ (ignore-errors
+ (shr-rescale-image data))))))
+ (when image
+ ;; When inserting big-ish pictures, put them at the
+ ;; beginning of the line.
+ (when (and (> (current-column) 0)
+ (> (car (image-size image t)) 400))
+ (insert "\n"))
+ (if (eq size 'original)
+ (insert-sliced-image image (or alt "*") nil 20 1)
+ (insert-image image (or alt "*")))
+ (put-text-property start (point) 'image-size size)
+ (when (cond ((fboundp 'image-multi-frame-p)
+ ;; Only animate multi-frame things that specify a
+ ;; delay; eg animated gifs as opposed to
+ ;; multi-page tiffs. FIXME?
+ (cdr (image-multi-frame-p image)))
+ ((fboundp 'image-animated-p)
+ (image-animated-p image)))
+ (image-animate image nil 60)))
+ image)
+ (insert alt)))
+
+(defun shr-rescale-image (data &optional force)
+ "Rescale DATA, if too big, to fit the current buffer.
+If FORCE, rescale the image anyway."
+ (let ((image (create-image data nil t :ascent 100)))
+ (if (or (not (fboundp 'imagemagick-types))
+ (not (get-buffer-window (current-buffer))))
+ image
+ (let* ((size (image-size image t))
+ (width (car size))
+ (height (cdr size))
+ (edges (window-inside-pixel-edges
+ (get-buffer-window (current-buffer))))
+ (window-width (truncate (* shr-max-image-proportion
+ (- (nth 2 edges) (nth 0 edges)))))
+ (window-height (truncate (* shr-max-image-proportion
+ (- (nth 3 edges) (nth 1 edges)))))
+ scaled-image)
+ (when (or force
+ (> height window-height))
+ (setq image (or (create-image data 'imagemagick t
+ :height window-height
+ :ascent 100)
+ image))
+ (setq size (image-size image t)))
+ (when (> (car size) window-width)
+ (setq image (or
+ (create-image data 'imagemagick t
+ :width window-width
+ :ascent 100)
+ image)))
+ image))))
+
+;; url-cache-extract autoloads url-cache.
+(declare-function url-cache-create-filename "url-cache" (url))
+(autoload 'mm-disable-multibyte "mm-util")
+(autoload 'browse-url-mail "browse-url")
+
+(defun shr-get-image-data (url)
+ "Get image data for URL.
+Return a string with image data."
+ (with-temp-buffer
+ (mm-disable-multibyte)
+ (when (ignore-errors
+ (url-cache-extract (url-cache-create-filename (shr-encode-url url)))
+ t)
+ (when (or (search-forward "\n\n" nil t)
+ (search-forward "\r\n\r\n" nil t))
+ (buffer-substring (point) (point-max))))))
+
+(defun shr-image-displayer (content-function)
+ "Return a function to display an image.
+CONTENT-FUNCTION is a function to retrieve an image for a cid url that
+is an argument. The function to be returned takes three arguments URL,
+START, and END. Note that START and END should be markers."
+ `(lambda (url start end)
+ (when url
+ (if (string-match "\\`cid:" url)
+ ,(when content-function
+ `(let ((image (funcall ,content-function
+ (substring url (match-end 0)))))
+ (when image
+ (goto-char start)
+ (funcall shr-put-image-function
+ image (buffer-substring start end))
+ (delete-region (point) end))))
+ (url-retrieve url 'shr-image-fetched
+ (list (current-buffer) start end)
+ t t)))))
+
+(defun shr-heading (cont &rest types)
+ (shr-ensure-paragraph)
+ (apply #'shr-fontize-cont cont types)
+ (shr-ensure-paragraph))
+
+(defun shr-urlify (start url &optional title)
+ (when (and title (string-match "ctx" title)) (debug))
+ (shr-add-font start (point) 'shr-link)
+ (add-text-properties
+ start (point)
+ (list 'shr-url url
+ 'help-echo (if title (format "%s (%s)" url title) url)
+ 'local-map shr-map)))
+
+(defun shr-encode-url (url)
+ "Encode URL."
+ (browse-url-url-encode-chars url "[)$ ]"))
+
+(autoload 'shr-color-visible "shr-color")
+(autoload 'shr-color->hexadecimal "shr-color")
+
+(defun shr-color-check (fg bg)
+ "Check that FG is visible on BG.
+Returns (fg bg) with corrected values.
+Returns nil if the colors that would be used are the default
+ones, in case fg and bg are nil."
+ (when (or fg bg)
+ (let ((fixed (cond ((null fg) 'fg)
+ ((null bg) 'bg))))
+ ;; Convert colors to hexadecimal, or set them to default.
+ (let ((fg (or (shr-color->hexadecimal fg)
+ (frame-parameter nil 'foreground-color)))
+ (bg (or (shr-color->hexadecimal bg)
+ (frame-parameter nil 'background-color))))
+ (cond ((eq fixed 'bg)
+ ;; Only return the new fg
+ (list nil (cadr (shr-color-visible bg fg t))))
+ ((eq fixed 'fg)
+ ;; Invert args and results and return only the new bg
+ (list (cadr (shr-color-visible fg bg t)) nil))
+ (t
+ (shr-color-visible bg fg)))))))
+
+(defun shr-colorize-region (start end fg &optional bg)
+ (when (and (not shr-inhibit-decoration)
+ (or fg bg))
+ (let ((new-colors (shr-color-check fg bg)))
+ (when new-colors
+ (when fg
+ (add-face-text-property start end
+ (list :foreground (cadr new-colors))
+ t))
+ (when bg
+ (add-face-text-property start end
+ (list :background (car new-colors))
+ t)))
+ new-colors)))
+
+(defun shr-expand-newlines (start end color)
+ (save-restriction
+ ;; Skip past all white space at the start and ends.
+ (goto-char start)
+ (skip-chars-forward " \t\n")
+ (beginning-of-line)
+ (setq start (point))
+ (goto-char end)
+ (skip-chars-backward " \t\n")
+ (forward-line 1)
+ (setq end (point))
+ (narrow-to-region start end)
+ (let ((width (shr-buffer-width))
+ column)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (end-of-line)
+ (when (and (< (setq column (current-column)) width)
+ (< (setq column (shr-previous-newline-padding-width column))
+ width))
+ (let ((overlay (make-overlay (point) (1+ (point)))))
+ (overlay-put overlay 'before-string
+ (concat
+ (mapconcat
+ (lambda (overlay)
+ (let ((string (plist-get
+ (overlay-properties overlay)
+ 'before-string)))
+ (if (not string)
+ ""
+ (overlay-put overlay 'before-string "")
+ string)))
+ (overlays-at (point))
+ "")
+ (propertize (make-string (- width column) ? )
+ 'face (list :background color))))))
+ (forward-line 1)))))
+
+(defun shr-previous-newline-padding-width (width)
+ (let ((overlays (overlays-at (point)))
+ (previous-width 0))
+ (if (null overlays)
+ width
+ (dolist (overlay overlays)
+ (setq previous-width
+ (+ previous-width
+ (length (plist-get (overlay-properties overlay)
+ 'before-string)))))
+ (+ width previous-width))))
+
+;;; Tag-specific rendering rules.
+
+(defun shr-tag-body (cont)
+ (let* ((start (point))
+ (fgcolor (cdr (or (assq :fgcolor cont)
+ (assq :text cont))))
+ (bgcolor (cdr (assq :bgcolor cont)))
+ (shr-stylesheet (list (cons 'color fgcolor)
+ (cons 'background-color bgcolor))))
+ (shr-generic cont)
+ (shr-colorize-region start (point) fgcolor bgcolor)))
+
+(defun shr-tag-style (cont)
+ )
+
+(defun shr-tag-script (cont)
+ )
+
+(defun shr-tag-comment (cont)
+ )
+
+(defun shr-dom-to-xml (dom)
+ "Convert DOM into a string containing the xml representation."
+ (let ((arg " ")
+ (text ""))
+ (dolist (sub (cdr dom))
+ (cond
+ ((listp (cdr sub))
+ (setq text (concat text (shr-dom-to-xml sub))))
+ ((eq (car sub) 'text)
+ (setq text (concat text (cdr sub))))
+ (t
+ (setq arg (concat arg (format "%s=\"%s\" "
+ (substring (symbol-name (car sub)) 1)
+ (cdr sub)))))))
+ (format "<%s%s>%s</%s>"
+ (car dom)
+ (substring arg 0 (1- (length arg)))
+ text
+ (car dom))))
+
+(defun shr-tag-svg (cont)
+ (when (image-type-available-p 'svg)
+ (funcall shr-put-image-function
+ (shr-dom-to-xml (cons 'svg cont))
+ "SVG Image")))
+
+(defun shr-tag-sup (cont)
+ (let ((start (point)))
+ (shr-generic cont)
+ (put-text-property start (point) 'display '(raise 0.5))))
+
+(defun shr-tag-sub (cont)
+ (let ((start (point)))
+ (shr-generic cont)
+ (put-text-property start (point) 'display '(raise -0.5))))
+
+(defun shr-tag-label (cont)
+ (shr-generic cont)
+ (shr-ensure-paragraph))
+
+(defun shr-tag-p (cont)
+ (shr-ensure-paragraph)
+ (shr-indent)
+ (shr-generic cont)
+ (shr-ensure-paragraph))
+
+(defun shr-tag-div (cont)
+ (shr-ensure-newline)
+ (shr-indent)
+ (shr-generic cont)
+ (shr-ensure-newline))
+
+(defun shr-tag-s (cont)
+ (shr-fontize-cont cont 'shr-strike-through))
+
+(defun shr-tag-del (cont)
+ (shr-fontize-cont cont 'shr-strike-through))
+
+(defun shr-tag-b (cont)
+ (shr-fontize-cont cont 'bold))
+
+(defun shr-tag-i (cont)
+ (shr-fontize-cont cont 'italic))
+
+(defun shr-tag-em (cont)
+ (shr-fontize-cont cont 'italic))
+
+(defun shr-tag-strong (cont)
+ (shr-fontize-cont cont 'bold))
+
+(defun shr-tag-u (cont)
+ (shr-fontize-cont cont 'underline))
+
+(defun shr-parse-style (style)
+ (when style
+ (save-match-data
+ (when (string-match "\n" style)
+ (setq style (replace-match " " t t style))))
+ (let ((plist nil))
+ (dolist (elem (split-string style ";"))
+ (when elem
+ (setq elem (split-string elem ":"))
+ (when (and (car elem)
+ (cadr elem))
+ (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem)))
+ (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem))))
+ (when (string-match " *!important\\'" value)
+ (setq value (substring value 0 (match-beginning 0))))
+ (push (cons (intern name obarray)
+ value)
+ plist)))))
+ plist)))
+
+(defun shr-tag-base (cont)
+ (let ((base (cdr (assq :href cont))))
+ (when base
+ (setq shr-base (shr-parse-base base))))
+ (shr-generic cont))
+
+(defun shr-tag-a (cont)
+ (let ((url (cdr (assq :href cont)))
+ (title (cdr (assq :title cont)))
+ (start (point))
+ shr-start)
+ (shr-generic cont)
+ (when (and url
+ (not shr-inhibit-decoration))
+ (shr-urlify (or shr-start start) (shr-expand-url url) title))))
+
+(defun shr-tag-object (cont)
+ (let ((start (point))
+ url)
+ (dolist (elem cont)
+ (when (eq (car elem) 'embed)
+ (setq url (or url (cdr (assq :src (cdr elem))))))
+ (when (and (eq (car elem) 'param)
+ (equal (cdr (assq :name (cdr elem))) "movie"))
+ (setq url (or url (cdr (assq :value (cdr elem)))))))
+ (when url
+ (shr-insert " [multimedia] ")
+ (shr-urlify start (shr-expand-url url)))
+ (shr-generic cont)))
+
+(defun shr-tag-video (cont)
+ (let ((image (cdr (assq :poster cont)))
+ (url (cdr (assq :src cont)))
+ (start (point)))
+ (shr-tag-img nil image)
+ (shr-urlify start (shr-expand-url url))))
+
+(defun shr-tag-img (cont &optional url)
+ (when (or url
+ (and cont
+ (cdr (assq :src cont))))
+ (when (and (> (current-column) 0)
+ (not (eq shr-state 'image)))
+ (insert "\n"))
+ (let ((alt (cdr (assq :alt cont)))
+ (url (shr-expand-url (or url (cdr (assq :src cont))))))
+ (let ((start (point-marker)))
+ (when (zerop (length alt))
+ (setq alt "*"))
+ (cond
+ ((or (member (cdr (assq :height cont)) '("0" "1"))
+ (member (cdr (assq :width cont)) '("0" "1")))
+ ;; Ignore zero-sized or single-pixel images.
+ )
+ ((and (not shr-inhibit-images)
+ (string-match "\\`data:" url))
+ (let ((image (shr-image-from-data (substring url (match-end 0)))))
+ (if image
+ (funcall shr-put-image-function image alt)
+ (insert alt))))
+ ((and (not shr-inhibit-images)
+ (string-match "\\`cid:" url))
+ (let ((url (substring url (match-end 0)))
+ image)
+ (if (or (not shr-content-function)
+ (not (setq image (funcall shr-content-function url))))
+ (insert alt)
+ (funcall shr-put-image-function image alt))))
+ ((or shr-inhibit-images
+ (and shr-blocked-images
+ (string-match shr-blocked-images url)))
+ (setq shr-start (point))
+ (let ((shr-state 'space))
+ (if (> (string-width alt) 8)
+ (shr-insert (truncate-string-to-width alt 8))
+ (shr-insert alt))))
+ ((and (not shr-ignore-cache)
+ (url-is-cached (shr-encode-url url)))
+ (funcall shr-put-image-function (shr-get-image-data url) alt))
+ (t
+ (insert alt " ")
+ (when (and shr-ignore-cache
+ (url-is-cached (shr-encode-url url)))
+ (let ((file (url-cache-create-filename (shr-encode-url url))))
+ (when (file-exists-p file)
+ (delete-file file))))
+ (url-queue-retrieve
+ (shr-encode-url url) 'shr-image-fetched
+ (list (current-buffer) start (set-marker (make-marker) (1- (point))))
+ t t)))
+ (when (zerop shr-table-depth) ;; We are not in a table.
+ (put-text-property start (point) 'keymap shr-map)
+ (put-text-property start (point) 'shr-alt alt)
+ (put-text-property start (point) 'image-url url)
+ (put-text-property start (point) 'image-displayer
+ (shr-image-displayer shr-content-function))
+ (put-text-property start (point) 'help-echo alt))
+ (setq shr-state 'image)))))
+
+(defun shr-tag-pre (cont)
+ (let ((shr-folding-mode 'none))
+ (shr-ensure-newline)
+ (shr-indent)
+ (shr-generic cont)
+ (shr-ensure-newline)))
+
+(defun shr-tag-blockquote (cont)
+ (shr-ensure-paragraph)
+ (shr-indent)
+ (let ((shr-indentation (+ shr-indentation 4)))
+ (shr-generic cont))
+ (shr-ensure-paragraph))
+
+(defun shr-tag-dl (cont)
+ (shr-ensure-paragraph)
+ (shr-generic cont)
+ (shr-ensure-paragraph))
+
+(defun shr-tag-dt (cont)
+ (shr-ensure-newline)
+ (shr-generic cont)
+ (shr-ensure-newline))
+
+(defun shr-tag-dd (cont)
+ (shr-ensure-newline)
+ (let ((shr-indentation (+ shr-indentation 4)))
+ (shr-generic cont)))
+
+(defun shr-tag-ul (cont)
+ (shr-ensure-paragraph)
+ (let ((shr-list-mode 'ul))
+ (shr-generic cont))
+ (shr-ensure-paragraph))
+
+(defun shr-tag-ol (cont)
+ (shr-ensure-paragraph)
+ (let ((shr-list-mode 1))
+ (shr-generic cont))
+ (shr-ensure-paragraph))
+
+(defun shr-tag-li (cont)
+ (shr-ensure-newline)
+ (shr-indent)
+ (let* ((bullet
+ (if (numberp shr-list-mode)
+ (prog1
+ (format "%d " shr-list-mode)
+ (setq shr-list-mode (1+ shr-list-mode)))
+ shr-bullet))
+ (shr-indentation (+ shr-indentation (length bullet))))
+ (insert bullet)
+ (shr-generic cont)))
+
+(defun shr-tag-br (cont)
+ (when (and (not (bobp))
+ ;; Only add a newline if we break the current line, or
+ ;; the previous line isn't a blank line.
+ (or (not (bolp))
+ (and (> (- (point) 2) (point-min))
+ (not (= (char-after (- (point) 2)) ?\n)))))
+ (insert "\n")
+ (shr-indent))
+ (shr-generic cont))
+
+(defun shr-tag-span (cont)
+ (shr-generic cont))
+
+(defun shr-tag-h1 (cont)
+ (shr-heading cont 'bold 'underline))
+
+(defun shr-tag-h2 (cont)
+ (shr-heading cont 'bold))
+
+(defun shr-tag-h3 (cont)
+ (shr-heading cont 'italic))
+
+(defun shr-tag-h4 (cont)
+ (shr-heading cont))
+
+(defun shr-tag-h5 (cont)
+ (shr-heading cont))
+
+(defun shr-tag-h6 (cont)
+ (shr-heading cont))
+
+(defun shr-tag-hr (cont)
+ (shr-ensure-newline)
+ (insert (make-string shr-width shr-hr-line) "\n"))
+
+(defun shr-tag-title (cont)
+ (shr-heading cont 'bold 'underline))
+
+(defun shr-tag-font (cont)
+ (let* ((start (point))
+ (color (cdr (assq :color cont)))
+ (shr-stylesheet (nconc (list (cons 'color color))
+ shr-stylesheet)))
+ (shr-generic cont)
+ (when color
+ (shr-colorize-region start (point) color
+ (cdr (assq 'background-color shr-stylesheet))))))
+
+;;; Table rendering algorithm.
+
+;; Table rendering is the only complicated thing here. We do this by
+;; first counting how many TDs there are in each TR, and registering
+;; how wide they think they should be ("width=45%", etc). Then we
+;; render each TD separately (this is done in temporary buffers, so
+;; that we can use all the rendering machinery as if we were in the
+;; main buffer). Now we know how much space each TD really takes, so
+;; we then render everything again with the new widths, and finally
+;; insert all these boxes into the main buffer.
+(defun shr-tag-table-1 (cont)
+ (setq cont (or (cdr (assq 'tbody cont))
+ cont))
+ (let* ((shr-inhibit-images t)
+ (shr-table-depth (1+ shr-table-depth))
+ (shr-kinsoku-shorten t)
+ ;; Find all suggested widths.
+ (columns (shr-column-specs cont))
+ ;; Compute how many characters wide each TD should be.
+ (suggested-widths (shr-pro-rate-columns columns))
+ ;; Do a "test rendering" to see how big each TD is (this can
+ ;; be smaller (if there's little text) or bigger (if there's
+ ;; unbreakable text).
+ (sketch (shr-make-table cont suggested-widths))
+ ;; Compute the "natural" width by setting each column to 500
+ ;; characters and see how wide they really render.
+ (natural (shr-make-table cont (make-vector (length columns) 500)))
+ (sketch-widths (shr-table-widths sketch natural suggested-widths)))
+ ;; This probably won't work very well.
+ (when (> (+ (loop for width across sketch-widths
+ summing (1+ width))
+ shr-indentation 1)
+ (frame-width))
+ (setq truncate-lines t))
+ ;; Then render the table again with these new "hard" widths.
+ (shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths)))
+
+(defun shr-tag-table (cont)
+ (shr-ensure-paragraph)
+ (let* ((caption (cdr (assq 'caption cont)))
+ (header (cdr (assq 'thead cont)))
+ (body (or (cdr (assq 'tbody cont)) cont))
+ (footer (cdr (assq 'tfoot cont)))
+ (bgcolor (cdr (assq :bgcolor cont)))
+ (start (point))
+ (shr-stylesheet (nconc (list (cons 'background-color bgcolor))
+ shr-stylesheet))
+ (nheader (if header (shr-max-columns header)))
+ (nbody (if body (shr-max-columns body)))
+ (nfooter (if footer (shr-max-columns footer))))
+ (if (and (not caption)
+ (not header)
+ (not (cdr (assq 'tbody cont)))
+ (not (cdr (assq 'tr cont)))
+ (not footer))
+ ;; The table is totally invalid and just contains random junk.
+ ;; Try to output it anyway.
+ (shr-generic cont)
+ ;; It's a real table, so render it.
+ (shr-tag-table-1
+ (nconc
+ (if caption `((tr (td ,@caption))))
+ (if header
+ (if footer
+ ;; hader + body + footer
+ (if (= nheader nbody)
+ (if (= nbody nfooter)
+ `((tr (td (table (tbody ,@header ,@body ,@footer)))))
+ (nconc `((tr (td (table (tbody ,@header ,@body)))))
+ (if (= nfooter 1)
+ footer
+ `((tr (td (table (tbody ,@footer))))))))
+ (nconc `((tr (td (table (tbody ,@header)))))
+ (if (= nbody nfooter)
+ `((tr (td (table (tbody ,@body ,@footer)))))
+ (nconc `((tr (td (table (tbody ,@body)))))
+ (if (= nfooter 1)
+ footer
+ `((tr (td (table (tbody ,@footer))))))))))
+ ;; header + body
+ (if (= nheader nbody)
+ `((tr (td (table (tbody ,@header ,@body)))))
+ (if (= nheader 1)
+ `(,@header (tr (td (table (tbody ,@body)))))
+ `((tr (td (table (tbody ,@header))))
+ (tr (td (table (tbody ,@body))))))))
+ (if footer
+ ;; body + footer
+ (if (= nbody nfooter)
+ `((tr (td (table (tbody ,@body ,@footer)))))
+ (nconc `((tr (td (table (tbody ,@body)))))
+ (if (= nfooter 1)
+ footer
+ `((tr (td (table (tbody ,@footer))))))))
+ (if caption
+ `((tr (td (table (tbody ,@body)))))
+ body))))))
+ (when bgcolor
+ (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
+ bgcolor))
+ ;; Finally, insert all the images after the table. The Emacs buffer
+ ;; model isn't strong enough to allow us to put the images actually
+ ;; into the tables.
+ (when (zerop shr-table-depth)
+ (dolist (elem (shr-find-elements cont 'img))
+ (shr-tag-img (cdr elem))))))
+
+(defun shr-find-elements (cont type)
+ (let (result)
+ (dolist (elem cont)
+ (cond ((eq (car elem) type)
+ (push elem result))
+ ((consp (cdr elem))
+ (setq result (nconc (shr-find-elements (cdr elem) type) result)))))
+ (nreverse result)))
+
+(defun shr-insert-table (table widths)
+ (let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet))
+ "collapse"))
+ (shr-table-vertical-line (if collapse "" shr-table-vertical-line)))
+ (unless collapse
+ (shr-insert-table-ruler widths))
+ (dolist (row table)
+ (let ((start (point))
+ (height (let ((max 0))
+ (dolist (column row)
+ (setq max (max max (cadr column))))
+ max)))
+ (dotimes (i height)
+ (shr-indent)
+ (insert shr-table-vertical-line "\n"))
+ (dolist (column row)
+ (goto-char start)
+ (let ((lines (nth 2 column)))
+ (dolist (line lines)
+ (end-of-line)
+ (insert line shr-table-vertical-line)
+ (forward-line 1))
+ ;; Add blank lines at padding at the bottom of the TD,
+ ;; possibly.
+ (dotimes (i (- height (length lines)))
+ (end-of-line)
+ (let ((start (point)))
+ (insert (make-string (string-width (car lines)) ? )
+ shr-table-vertical-line)
+ (when (nth 4 column)
+ (shr-add-font start (1- (point))
+ (list :background (nth 4 column)))))
+ (forward-line 1)))))
+ (unless collapse
+ (shr-insert-table-ruler widths)))))
+
+(defun shr-insert-table-ruler (widths)
+ (when (and (bolp)
+ (> shr-indentation 0))
+ (shr-indent))
+ (insert shr-table-corner)
+ (dotimes (i (length widths))
+ (insert (make-string (aref widths i) shr-table-horizontal-line)
+ shr-table-corner))
+ (insert "\n"))
+
+(defun shr-table-widths (table natural-table suggested-widths)
+ (let* ((length (length suggested-widths))
+ (widths (make-vector length 0))
+ (natural-widths (make-vector length 0)))
+ (dolist (row table)
+ (let ((i 0))
+ (dolist (column row)
+ (aset widths i (max (aref widths i) column))
+ (setq i (1+ i)))))
+ (dolist (row natural-table)
+ (let ((i 0))
+ (dolist (column row)
+ (aset natural-widths i (max (aref natural-widths i) column))
+ (setq i (1+ i)))))
+ (let ((extra (- (apply '+ (append suggested-widths nil))
+ (apply '+ (append widths nil))))
+ (expanded-columns 0))
+ ;; We have extra, unused space, so divide this space amongst the
+ ;; columns.
+ (when (> extra 0)
+ ;; If the natural width is wider than the rendered width, we
+ ;; want to allow the column to expand.
+ (dotimes (i length)
+ (when (> (aref natural-widths i) (aref widths i))
+ (setq expanded-columns (1+ expanded-columns))))
+ (dotimes (i length)
+ (when (> (aref natural-widths i) (aref widths i))
+ (aset widths i (min
+ (aref natural-widths i)
+ (+ (/ extra expanded-columns)
+ (aref widths i))))))))
+ widths))
+
+(defun shr-make-table (cont widths &optional fill)
+ (or (cadr (assoc (list cont widths fill) shr-content-cache))
+ (let ((data (shr-make-table-1 cont widths fill)))
+ (push (list (list cont widths fill) data)
+ shr-content-cache)
+ data)))
+
+(defun shr-make-table-1 (cont widths &optional fill)
+ (let ((trs nil)
+ (shr-inhibit-decoration (not fill)))
+ (dolist (row cont)
+ (when (eq (car row) 'tr)
+ (let ((tds nil)
+ (columns (cdr row))
+ (i 0)
+ column)
+ (while (< i (length widths))
+ (setq column (pop columns))
+ (when (or (memq (car column) '(td th))
+ (null column))
+ (push (shr-render-td (cdr column) (aref widths i) fill)
+ tds)
+ (setq i (1+ i))))
+ (push (nreverse tds) trs))))
+ (nreverse trs)))
+
+(defun shr-render-td (cont width fill)
+ (with-temp-buffer
+ (let ((bgcolor (cdr (assq :bgcolor cont)))
+ (fgcolor (cdr (assq :fgcolor cont)))
+ (style (cdr (assq :style cont)))
+ (shr-stylesheet shr-stylesheet)
+ actual-colors)
+ (when style
+ (setq style (and (string-match "color" style)
+ (shr-parse-style style))))
+ (when bgcolor
+ (setq style (nconc (list (cons 'background-color bgcolor)) style)))
+ (when fgcolor
+ (setq style (nconc (list (cons 'color fgcolor)) style)))
+ (when style
+ (setq shr-stylesheet (append style shr-stylesheet)))
+ (let ((shr-width width)
+ (shr-indentation 0))
+ (shr-descend (cons 'td cont)))
+ ;; Delete padding at the bottom of the TDs.
+ (delete-region
+ (point)
+ (progn
+ (skip-chars-backward " \t\n")
+ (end-of-line)
+ (point)))
+ (goto-char (point-min))
+ (let ((max 0))
+ (while (not (eobp))
+ (end-of-line)
+ (setq max (max max (current-column)))
+ (forward-line 1))
+ (when fill
+ (goto-char (point-min))
+ ;; If the buffer is totally empty, then put a single blank
+ ;; line here.
+ (if (zerop (buffer-size))
+ (insert (make-string width ? ))
+ ;; Otherwise, fill the buffer.
+ (let ((align (cdr (assq :align cont)))
+ length)
+ (while (not (eobp))
+ (end-of-line)
+ (setq length (- width (current-column)))
+ (when (> length 0)
+ (cond
+ ((equal align "right")
+ (beginning-of-line)
+ (insert (make-string length ? )))
+ ((equal align "center")
+ (insert (make-string (/ length 2) ? ))
+ (beginning-of-line)
+ (insert (make-string (- length (/ length 2)) ? )))
+ (t
+ (insert (make-string length ? )))))
+ (forward-line 1))))
+ (when style
+ (setq actual-colors
+ (shr-colorize-region
+ (point-min) (point-max)
+ (cdr (assq 'color shr-stylesheet))
+ (cdr (assq 'background-color shr-stylesheet))))))
+ (if fill
+ (list max
+ (count-lines (point-min) (point-max))
+ (split-string (buffer-string) "\n")
+ nil
+ (car actual-colors))
+ max)))))
+
+(defun shr-buffer-width ()
+ (goto-char (point-min))
+ (let ((max 0))
+ (while (not (eobp))
+ (end-of-line)
+ (setq max (max max (current-column)))
+ (forward-line 1))
+ max))
+
+(defun shr-pro-rate-columns (columns)
+ (let ((total-percentage 0)
+ (widths (make-vector (length columns) 0)))
+ (dotimes (i (length columns))
+ (setq total-percentage (+ total-percentage (aref columns i))))
+ (setq total-percentage (/ 1.0 total-percentage))
+ (dotimes (i (length columns))
+ (aset widths i (max (truncate (* (aref columns i)
+ total-percentage
+ (- shr-width (1+ (length columns)))))
+ 10)))
+ widths))
+
+;; Return a summary of the number and shape of the TDs in the table.
+(defun shr-column-specs (cont)
+ (let ((columns (make-vector (shr-max-columns cont) 1)))
+ (dolist (row cont)
+ (when (eq (car row) 'tr)
+ (let ((i 0))
+ (dolist (column (cdr row))
+ (when (memq (car column) '(td th))
+ (let ((width (cdr (assq :width (cdr column)))))
+ (when (and width
+ (string-match "\\([0-9]+\\)%" width)
+ (not (zerop (setq width (string-to-number
+ (match-string 1 width))))))
+ (aset columns i (/ width 100.0))))
+ (setq i (1+ i)))))))
+ columns))
+
+(defun shr-count (cont elem)
+ (let ((i 0))
+ (dolist (sub cont)
+ (when (eq (car sub) elem)
+ (setq i (1+ i))))
+ i))
+
+(defun shr-max-columns (cont)
+ (let ((max 0))
+ (dolist (row cont)
+ (when (eq (car row) 'tr)
+ (setq max (max max (+ (shr-count (cdr row) 'td)
+ (shr-count (cdr row) 'th))))))
+ max))
+
+;; Emacs less than 24.3
+(unless (fboundp 'add-face-text-property)
+ (defun add-face-text-property (beg end face &optional appendp object)
+ "Combine FACE BEG and END."
+ (let ((b beg))
+ (while (< b end)
+ (let ((oldval (get-text-property b 'face)))
+ (put-text-property
+ b (setq b (next-single-property-change b 'face nil end))
+ 'face (cond ((null oldval)
+ face)
+ ((and (consp oldval)
+ (not (keywordp (car oldval))))
+ (if appendp
+ (nconc oldval (list face))
+ (cons face oldval)))
+ (t
+ (if appendp
+ (list oldval face)
+ (list face oldval))))))))))
+
+(provide 'shr)
+
+;; Local Variables:
+;; coding: utf-8
+;; End:
+
+;;; shr.el ends here
projects / emacs.git / commitdiff