From 4ba54f7d9d2c39a245ba6f527a956cd775133e86 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Tue, 18 Jun 2013 14:04:09 -0400 Subject: Move some files from gnus/ to net/ Ref: http://lists.gnu.org/archive/html/emacs-devel/2013-06/msg00567.html --- lisp/ChangeLog | 2 + lisp/gnus/ChangeLog | 4 + lisp/gnus/eww.el | 483 --------------- lisp/gnus/shr-color.el | 363 ----------- lisp/gnus/shr.el | 1603 ------------------------------------------------ lisp/net/eww.el | 483 +++++++++++++++ lisp/net/shr-color.el | 363 +++++++++++ lisp/net/shr.el | 1603 ++++++++++++++++++++++++++++++++++++++++++++++++ 8 files changed, 2455 insertions(+), 2449 deletions(-) delete mode 100644 lisp/gnus/eww.el delete mode 100644 lisp/gnus/shr-color.el delete mode 100644 lisp/gnus/shr.el create mode 100644 lisp/net/eww.el create mode 100644 lisp/net/shr-color.el create mode 100644 lisp/net/shr.el diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 023e11a941..61a3397f65 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,7 @@ 2013-06-18 Glenn Morris + * 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) diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 7f3dae659b..fc668100f3 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,7 @@ +2013-06-18 Glenn Morris + + * eww.el, shr.el, shr-color.el: Move to ../net. + 2013-06-18 Lars Magne Ingebrigtsen * shr.el (shr-tag-table): Insert the images after the table, so that diff --git a/lisp/gnus/eww.el b/lisp/gnus/eww.el deleted file mode 100644 index 3914f06718..0000000000 --- a/lisp/gnus/eww.el +++ /dev/null @@ -1,483 +0,0 @@ -;;; eww.el --- Emacs Web Wowser - -;; Copyright (C) 2013 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; 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 . - -;;; 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 - "]*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 diff --git a/lisp/gnus/shr-color.el b/lisp/gnus/shr-color.el deleted file mode 100644 index 21f1fc4f00..0000000000 --- a/lisp/gnus/shr-color.el +++ /dev/null @@ -1,363 +0,0 @@ -;;; shr-color.el --- Simple HTML Renderer color management - -;; Copyright (C) 2010-2013 Free Software Foundation, Inc. - -;; Author: Julien Danjou -;; 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 . - -;;; 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 diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el deleted file mode 100644 index f3a396a94b..0000000000 --- a/lisp/gnus/shr.el +++ /dev/null @@ -1,1603 +0,0 @@ -;;; shr.el --- Simple HTML Renderer - -;; Copyright (C) 2010-2013 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; 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 . - -;;; 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 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" - (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 diff --git a/lisp/net/eww.el b/lisp/net/eww.el new file mode 100644 index 0000000000..3914f06718 --- /dev/null +++ b/lisp/net/eww.el @@ -0,0 +1,483 @@ +;;; eww.el --- Emacs Web Wowser + +;; Copyright (C) 2013 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; 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 . + +;;; 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 + "]*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 diff --git a/lisp/net/shr-color.el b/lisp/net/shr-color.el new file mode 100644 index 0000000000..21f1fc4f00 --- /dev/null +++ b/lisp/net/shr-color.el @@ -0,0 +1,363 @@ +;;; shr-color.el --- Simple HTML Renderer color management + +;; Copyright (C) 2010-2013 Free Software Foundation, Inc. + +;; Author: Julien Danjou +;; 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 . + +;;; 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 diff --git a/lisp/net/shr.el b/lisp/net/shr.el new file mode 100644 index 0000000000..f3a396a94b --- /dev/null +++ b/lisp/net/shr.el @@ -0,0 +1,1603 @@ +;;; shr.el --- Simple HTML Renderer + +;; Copyright (C) 2010-2013 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; 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 . + +;;; 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 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" + (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 -- cgit v1.2.3