[gnus git] branch master updated: m0-7-151-g9115bd5 =1= * eww.el, shr.el, shr-color.el: Removed from the Gnus repository.
Lars Magne Ingebrigtsen <[email protected]>
| Newsgroups | gmane.emacs.gnus.cvs |
|---|---|
| Message-ID | <[email protected]> |
via 9115bd58b634b2739610c9a8b2f9748f92d4385d (commit)
from 9cd19667eb3ce2fb021bf294cb50ea648341f2f3 (commit)
- Log -----------------------------------------------------------------
commit 9115bd58b634b2739610c9a8b2f9748f92d4385d
Author: Lars Magne Ingebrigtsen <[email protected]>
Date: Sun Jun 23 20:15:22 2013 +0200
* eww.el, shr.el, shr-color.el: Removed from the Gnus repository.
They now live in the lisp/net Emacs 24 repository.
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index a8c1d4f..b7c5f56 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,8 @@
+2013-06-23 Lars Magne Ingebrigtsen <[email protected]>
+
+ * eww.el, shr.el, shr-color.el: Removed from the Gnus repository. They
+ now live in the lisp/net Emacs 24 repository.
+
2013-06-21 Lars Magne Ingebrigtsen <[email protected]>
* eww.el (eww-update-header-line-format): Quote % characters.
diff --git a/lisp/dgnushack.el b/lisp/dgnushack.el
index dfe44a1..ad3ac8c 100644
--- a/lisp/dgnushack.el
+++ b/lisp/dgnushack.el
@@ -334,7 +334,7 @@ This means that every warning will be reported as an error."
;; lpath.el binds it.
(not (eq (symbol-function 'libxml-parse-html-region)
'ignore)))
- (dolist (file '("color.el" "shr-color.el" "shr.el" "eww.el"))
+ (dolist (file '("color.el"))
(setq files (delete file files))))
(unless (locate-library "epg")
(setq files (delete "plstore.el" files)))
diff --git a/lisp/eww.el b/lisp/eww.el
deleted file mode 100644
index ad19758..0000000
--- a/lisp/eww.el
+++ /dev/null
@@ -1,815 +0,0 @@
-;;; eww.el --- Emacs Web Wowser
-
-;; Copyright (C) 2013 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <[email protected]>
-;; Keywords: html
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'format-spec)
-(require 'shr)
-(require 'url)
-(require 'mm-url)
-
-(defgroup eww nil
- "Emacs Web Wowser"
- :version "24.4"
- :group 'hypermedia
- :prefix "eww-")
-
-(defcustom eww-header-line-format "%t: %u"
- "Header line format.
-- %t is replaced by the title.
-- %u is replaced by the URL."
- :group 'eww
- :type 'string)
-
-(defface eww-form-submit
- '((((type x w32 ns) (class color)) ; Like default mode line
- :box (:line-width 2 :style released-button)
- :background "#808080" :foreground "black"))
- "Face for eww buffer buttons."
- :version "24.4"
- :group 'eww)
-
-(defface eww-form-checkbox
- '((((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)
-
-(defface eww-form-select
- '((((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)
-
-(defface eww-form-text
- '((t (:background "#505050"
- :foreground "white"
- :box (:line-width 1))))
- "Face for eww text inputs."
- :version "24.4"
- :group 'eww)
-
-(defvar eww-current-url nil)
-(defvar eww-current-title ""
- "Title of current page.")
-(defvar eww-history nil)
-
-(defvar eww-next-url nil)
-(defvar eww-previous-url nil)
-(defvar eww-up-url nil)
-(defvar eww-home-url nil)
-(defvar eww-start-url nil)
-(defvar eww-contents-url 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)))
-
-;;;###autoload
-(defun eww-open-file (file)
- "Render a file using EWW."
- (interactive "fFile: ")
- (eww (concat "file://" (expand-file-name file))))
-
-(defun eww-render (status url &optional point)
- (let ((redirect (plist-get status :redirect)))
- (when redirect
- (setq url redirect)))
- (set (make-local-variable 'eww-next-url) nil)
- (set (make-local-variable 'eww-previous-url) nil)
- (set (make-local-variable 'eww-up-url) nil)
- (set (make-local-variable 'eww-home-url) nil)
- (set (make-local-variable 'eww-start-url) nil)
- (set (make-local-variable 'eww-contents-url) nil)
- (let* ((headers (eww-parse-headers))
- (shr-target-id
- (and (string-match "#\\(.*\\)" url)
- (match-string 1 url)))
- (content-type
- (mail-header-parse-content-type
- (or (cdr (assoc "content-type" headers))
- "text/plain")))
- (charset (intern
- (downcase
- (or (cdr (assq 'charset (cdr content-type)))
- (eww-detect-charset (equal (car content-type)
- "text/html"))
- "utf8"))))
- (data-buffer (current-buffer)))
- (unwind-protect
- (progn
- (cond
- ((equal (car content-type) "text/html")
- (eww-display-html charset url))
- ((string-match "^image/" (car content-type))
- (eww-display-image))
- (t
- (eww-display-raw charset)))
- (cond
- (point
- (goto-char point))
- (shr-target-id
- (let ((point (next-single-property-change
- (point-min) 'shr-target-id)))
- (when point
- (goto-char (1+ point)))))))
- (kill-buffer data-buffer))))
-
-(defun eww-parse-headers ()
- (let ((headers nil))
- (goto-char (point-min))
- (while (and (not (eobp))
- (not (eolp)))
- (when (looking-at "\\([^:]+\\): *\\(.*\\)")
- (push (cons (downcase (match-string 1))
- (match-string 2))
- headers))
- (forward-line 1))
- (unless (eobp)
- (forward-line 1))
- headers))
-
-(defun eww-detect-charset (html-p)
- (let ((case-fold-search t)
- (pt (point)))
- (or (and html-p
- (re-search-forward
- "<meta[\t\n\r ]+[^>]*charset=\"?\\([^\t\n\r \"/>]+\\)" nil t)
- (goto-char pt)
- (match-string 1))
- (and (looking-at
- "[\t\n\r ]*<\\?xml[\t\n\r ]+[^>]*encoding=\"\\([^\"]+\\)")
- (match-string 1)))))
-
-(defun eww-display-html (charset url)
- (unless (eq charset 'utf8)
- (decode-coding-region (point) (point-max) charset))
- (let ((document
- (list
- 'base (list (cons 'href url))
- (libxml-parse-html-region (point) (point-max)))))
- (eww-setup-buffer)
- (setq eww-current-url url)
- (eww-update-header-line-format)
- (let ((inhibit-read-only t)
- (after-change-functions nil)
- (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)
- (link . eww-tag-link)
- (a . eww-tag-a))))
- (shr-insert-document document))
- (goto-char (point-min))))
-
-(defun eww-handle-link (cont)
- (let* ((rel (assq :rel cont))
- (href (assq :href cont))
- (where (assoc
- ;; The text associated with :rel is case-insensitive.
- (if rel (downcase (cdr rel)))
- '(("next" . eww-next-url)
- ;; Texinfo uses "previous", but HTML specifies
- ;; "prev", so recognize both.
- ("previous" . eww-previous-url)
- ("prev" . eww-previous-url)
- ;; HTML specifies "start" but also "contents",
- ;; and Gtk seems to use "home". Recognize
- ;; them all; but store them in different
- ;; variables so that we can readily choose the
- ;; "best" one.
- ("start" . eww-start-url)
- ("home" . eww-home-url)
- ("contents" . eww-contents-url)
- ("up" . eww-up-url)))))
- (and href
- where
- (set (cdr where) (cdr href)))))
-
-(defun eww-tag-link (cont)
- (eww-handle-link cont)
- (shr-generic cont))
-
-(defun eww-tag-a (cont)
- (eww-handle-link cont)
- (shr-tag-a cont))
-
-(defun eww-update-header-line-format ()
- (if eww-header-line-format
- (setq header-line-format
- (replace-regexp-in-string
- "%" "%%"
- (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))
- t))
- (when bg
- (add-face-text-property start end
- (list :background (car new-colors))
- t))))))
-
-(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)
- (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 "l" 'eww-back-url)
- (define-key map "n" 'eww-next-url)
- (define-key map "p" 'eww-previous-url)
- (define-key map "u" 'eww-up-url)
- (define-key map "t" 'eww-top-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)
- (set (make-local-variable 'after-change-functions) 'eww-process-text-input)
- ;;(setq buffer-read-only t)
- )
-
-(defun eww-browse-url (url &optional new-window)
- (when (and (equal major-mode 'eww-mode)
- eww-current-url)
- (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-back-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-next-url ()
- "Go to the page marked `next'.
-A page is marked `next' if rel=\"next\" appears in a <link>
-or <a> tag."
- (interactive)
- (if eww-next-url
- (eww-browse-url (shr-expand-url eww-next-url eww-current-url))
- (error "No `next' on this page")))
-
-(defun eww-previous-url ()
- "Go to the page marked `previous'.
-A page is marked `previous' if rel=\"previous\" appears in a <link>
-or <a> tag."
- (interactive)
- (if eww-previous-url
- (eww-browse-url (shr-expand-url eww-previous-url eww-current-url))
- (error "No `previous' on this page")))
-
-(defun eww-up-url ()
- "Go to the page marked `up'.
-A page is marked `up' if rel=\"up\" appears in a <link>
-or <a> tag."
- (interactive)
- (if eww-up-url
- (eww-browse-url (shr-expand-url eww-up-url eww-current-url))
- (error "No `up' on this page")))
-
-(defun eww-top-url ()
- "Go to the page marked `top'.
-A page is marked `top' if rel=\"start\", rel=\"home\", or rel=\"contents\"
-appears in a <link> or <a> tag."
- (interactive)
- (let ((best-url (or eww-start-url
- eww-contents-url
- eww-home-url)))
- (if best-url
- (eww-browse-url (shr-expand-url best-url eww-current-url))
- (error "No `top' for this page"))))
-
-(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)
-
-(defvar eww-submit-map
- (let ((map (make-sparse-keymap)))
- (define-key map "\r" 'eww-submit)
- map))
-
-(defvar eww-checkbox-map
- (let ((map (make-sparse-keymap)))
- (define-key map [space] 'eww-toggle-checkbox)
- (define-key map "\r" 'eww-toggle-checkbox)
- map))
-
-(defvar eww-text-map
- (let ((map (make-keymap)))
- (set-keymap-parent map text-mode-map)
- (define-key map "\r" 'eww-submit)
- (define-key map [(control a)] 'eww-beginning-of-text)
- (define-key map [(control e)] 'eww-end-of-text)
- (define-key map [tab] 'shr-next-link)
- (define-key map [backtab] 'shr-previous-link)
- map))
-
-(defvar eww-textarea-map
- (let ((map (make-keymap)))
- (set-keymap-parent map text-mode-map)
- (define-key map "\r" 'forward-line)
- (define-key map [tab] 'shr-next-link)
- (define-key map [backtab] 'shr-previous-link)
- map))
-
-(defvar eww-select-map
- (let ((map (make-sparse-keymap)))
- (define-key map "\r" 'eww-change-select)
- map))
-
-(defun eww-beginning-of-text ()
- "Move to the start of the input field."
- (interactive)
- (goto-char (eww-beginning-of-field)))
-
-(defun eww-end-of-text ()
- "Move to the end of the text in the input field."
- (interactive)
- (goto-char (eww-end-of-field))
- (let ((start (eww-beginning-of-field)))
- (while (and (equal (following-char) ? )
- (> (point) start))
- (forward-char -1))
- (when (> (point) start)
- (forward-char 1))))
-
-(defun eww-beginning-of-field ()
- (cond
- ((bobp)
- (point))
- ((not (eq (get-text-property (point) 'eww-form)
- (get-text-property (1- (point)) 'eww-form)))
- (point))
- (t
- (previous-single-property-change
- (point) 'eww-form nil (point-min)))))
-
-(defun eww-end-of-field ()
- (1- (next-single-property-change
- (point) 'eww-form nil (point-max))))
-
-(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-form-submit (cont)
- (let ((start (point))
- (value (cdr (assq :value cont))))
- (setq value
- (if (zerop (length value))
- "Submit"
- value))
- (insert value)
- (add-face-text-property start (point) 'eww-form-submit)
- (put-text-property start (point) 'eww-form
- (list :eww-form eww-form
- :value value
- :type "submit"
- :name (cdr (assq :name cont))))
- (put-text-property start (point) 'keymap eww-submit-map)
- (insert " ")))
-
-(defun eww-form-checkbox (cont)
- (let ((start (point)))
- (if (cdr (assq :checked cont))
- (insert "[X]")
- (insert "[ ]"))
- (add-face-text-property start (point) 'eww-form-checkbox)
- (put-text-property start (point) 'eww-form
- (list :eww-form eww-form
- :value (cdr (assq :value cont))
- :type (downcase (cdr (assq :type cont)))
- :checked (cdr (assq :checked cont))
- :name (cdr (assq :name cont))))
- (put-text-property start (point) 'keymap eww-checkbox-map)
- (insert " ")))
-
-(defun eww-form-text (cont)
- (let ((start (point))
- (type (downcase (or (cdr (assq :type cont))
- "text")))
- (value (or (cdr (assq :value cont)) ""))
- (width (string-to-number
- (or (cdr (assq :size cont))
- "40"))))
- (insert value)
- (when (< (length value) width)
- (insert (make-string (- width (length value)) ? )))
- (put-text-property start (point) 'face 'eww-form-text)
- (put-text-property start (point) 'local-map eww-text-map)
- (put-text-property start (point) 'inhibit-read-only t)
- (put-text-property start (point) 'eww-form
- (list :eww-form eww-form
- :value value
- :type type
- :name (cdr (assq :name cont))))
- (insert " ")))
-
-(defun eww-process-text-input (beg end length)
- (let* ((form (get-text-property end 'eww-form))
- (properties (text-properties-at end))
- (type (plist-get form :type)))
- (when (and form
- (member type '("text" "password" "textarea")))
- (cond
- ((zerop length)
- ;; Delete some space at the end.
- (save-excursion
- (goto-char
- (if (equal type "textarea")
- (1- (line-end-position))
- (eww-end-of-field)))
- (let ((new (- end beg)))
- (while (and (> new 0)
- (eql (following-char) ? ))
- (delete-region (point) (1+ (point)))
- (setq new (1- new))))
- (set-text-properties beg end properties)))
- ((> length 0)
- ;; Add padding.
- (save-excursion
- (goto-char
- (if (equal type "textarea")
- (1- (line-end-position))
- (eww-end-of-field)))
- (let ((start (point)))
- (insert (make-string length ? ))
- (set-text-properties start (point) properties)))))
- (let ((value (buffer-substring-no-properties
- (eww-beginning-of-field)
- (eww-end-of-field))))
- (when (string-match " +\\'" value)
- (setq value (substring value 0 (match-beginning 0))))
- (plist-put form :value value)
- (when (equal type "password")
- ;; Display passwords as asterisks.
- (let ((start (eww-beginning-of-field)))
- (put-text-property start (+ start (length value))
- 'display (make-string (length value) ?*))))))))
-
-(defun eww-tag-textarea (cont)
- (let ((start (point))
- (value (or (cdr (assq :value cont)) ""))
- (lines (string-to-number
- (or (cdr (assq :rows cont))
- "10")))
- (width (string-to-number
- (or (cdr (assq :cols cont))
- "10")))
- end)
- (shr-ensure-newline)
- (insert value)
- (shr-ensure-newline)
- (when (< (count-lines start (point)) lines)
- (dotimes (i (- lines (count-lines start (point))))
- (insert "\n")))
- (setq end (point-marker))
- (goto-char start)
- (while (< (point) end)
- (end-of-line)
- (let ((pad (- width (- (point) (line-beginning-position)))))
- (when (> pad 0)
- (insert (make-string pad ? ))))
- (add-face-text-property (line-beginning-position)
- (point) 'eww-form-text)
- (put-text-property (line-beginning-position) (point)
- 'local-map eww-textarea-map)
- (forward-line 1))
- (put-text-property start (point) 'eww-form
- (list :eww-form eww-form
- :value value
- :type "textarea"
- :name (cdr (assq :name cont))))))
-
-(defun eww-tag-input (cont)
- (let ((type (downcase (or (cdr (assq :type cont))
- "text")))
- (start (point)))
- (cond
- ((or (equal type "checkbox")
- (equal type "radio"))
- (eww-form-checkbox cont))
- ((equal type "submit")
- (eww-form-submit cont))
- ((equal type "hidden")
- (let ((form eww-form)
- (name (cdr (assq :name cont))))
- ;; Don't add <input type=hidden> elements repeatedly.
- (while (and form
- (or (not (consp (car form)))
- (not (eq (caar form) 'hidden))
- (not (equal (plist-get (cdr (car form)) :name)
- name))))
- (setq form (cdr form)))
- (unless form
- (nconc eww-form (list
- (list 'hidden
- :name name
- :value (cdr (assq :value cont))))))))
- (t
- (eww-form-text cont)))
- (unless (= start (point))
- (put-text-property start (1+ start) 'help-echo "Input field"))))
-
-(defun eww-tag-select (cont)
- (shr-ensure-paragraph)
- (let ((menu (list :name (cdr (assq :name cont))
- :eww-form eww-form))
- (options nil)
- (start (point))
- (max 0))
- (dolist (elem cont)
- (when (eq (car elem) 'option)
- (when (cdr (assq :selected (cdr elem)))
- (nconc menu (list :value
- (cdr (assq :value (cdr elem))))))
- (let ((display (or (cdr (assq 'text (cdr elem))) "")))
- (setq max (max max (length display)))
- (push (list 'item
- :value (cdr (assq :value (cdr elem)))
- :display display)
- options))))
- (when options
- (setq options (nreverse options))
- ;; If we have no selected values, default to the first value.
- (unless (plist-get menu :value)
- (nconc menu (list :value (nth 2 (car options)))))
- (nconc menu options)
- (let ((selected (eww-select-display menu)))
- (insert selected
- (make-string (- max (length selected)) ? )))
- (put-text-property start (point) 'eww-form menu)
- (add-face-text-property start (point) 'eww-form-select)
- (put-text-property start (point) 'keymap eww-select-map)
- (shr-ensure-paragraph))))
-
-(defun eww-select-display (select)
- (let ((value (plist-get select :value))
- display)
- (dolist (elem select)
- (when (and (consp elem)
- (eq (car elem) 'item)
- (equal value (plist-get (cdr elem) :value)))
- (setq display (plist-get (cdr elem) :display))))
- display))
-
-(defun eww-change-select ()
- "Change the value of the select drop-down menu under point."
- (interactive)
- (let* ((input (get-text-property (point) 'eww-form))
- (properties (text-properties-at (point)))
- (completion-ignore-case t)
- (options
- (delq nil
- (mapcar (lambda (elem)
- (and (consp elem)
- (eq (car elem) 'item)
- (cons (plist-get (cdr elem) :display)
- (plist-get (cdr elem) :value))))
- input)))
- (display
- (completing-read "Change value: " options nil 'require-match))
- (inhibit-read-only t))
- (plist-put input :value (cdr (assoc-string display options t)))
- (goto-char
- (eww-update-field display))))
-
-(defun eww-update-field (string)
- (let ((properties (text-properties-at (point)))
- (start (eww-beginning-of-field))
- (end (1+ (eww-end-of-field))))
- (delete-region start end)
- (insert string
- (make-string (- (- end start) (length string)) ? ))
- (set-text-properties start end properties)
- start))
-
-(defun eww-toggle-checkbox ()
- "Toggle the value of the checkbox under point."
- (interactive)
- (let* ((input (get-text-property (point) 'eww-form))
- (type (plist-get input :type)))
- (if (equal type "checkbox")
- (goto-char
- (1+
- (if (plist-get input :checked)
- (progn
- (plist-put input :checked nil)
- (eww-update-field "[ ]"))
- (plist-put input :checked t)
- (eww-update-field "[X]"))))
- ;; Radio button. Switch all other buttons off.
- (let ((name (plist-get input :name)))
- (save-excursion
- (dolist (elem (eww-inputs (plist-get input :eww-form)))
- (when (equal (plist-get (cdr elem) :name) name)
- (goto-char (car elem))
- (if (not (eq (cdr elem) input))
- (progn
- (plist-put input :checked nil)
- (eww-update-field "[ ]"))
- (plist-put input :checked t)
- (eww-update-field "[X]")))))
- (forward-char 1)))))
-
-(defun eww-inputs (form)
- (let ((start (point-min))
- (inputs nil))
- (while (and start
- (< start (point-max)))
- (when (or (get-text-property start 'eww-form)
- (setq start (next-single-property-change start 'eww-form)))
- (when (eq (plist-get (get-text-property start 'eww-form) :eww-form)
- form)
- (push (cons start (get-text-property start 'eww-form))
- inputs))
- (setq start (next-single-property-change start 'eww-form))))
- (nreverse inputs)))
-
-(defun eww-input-value (input)
- (let ((type (plist-get input :type))
- (value (plist-get input :value)))
- (cond
- ((equal type "textarea")
- (with-temp-buffer
- (insert value)
- (goto-char (point-min))
- (while (re-search-forward "^ +\n\\| +$" nil t)
- (replace-match "" t t))
- (buffer-string)))
- (t
- (if (string-match " +\\'" value)
- (substring value 0 (match-beginning 0))
- value)))))
-
-(defun eww-submit ()
- "Submit the current form."
- (interactive)
- (let* ((this-input (get-text-property (point) 'eww-form))
- (form (plist-get this-input :eww-form))
- values next-submit)
- (dolist (elem (sort (eww-inputs form)
- (lambda (o1 o2)
- (< (car o1) (car o2)))))
- (let* ((input (cdr elem))
- (input-start (car elem))
- (name (plist-get input :name)))
- (when name
- (cond
- ((member (plist-get input :type) '("checkbox" "radio"))
- (when (plist-get input :checked)
- (push (cons name (plist-get input :value))
- values)))
- ((equal (plist-get input :type) "submit")
- ;; We want the values from buttons if we hit a button if
- ;; we hit enter on it, or if it's the first button after
- ;; the field we did hit return on.
- (when (or (eq input this-input)
- (and (not (eq input this-input))
- (null next-submit)
- (> input-start (point))))
- (setq next-submit t)
- (push (cons name (plist-get input :value))
- values)))
- (t
- (push (cons name (eww-input-value input))
- 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 (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))))))
-
-(provide 'eww)
-
-;;; eww.el ends here
diff --git a/lisp/shr-color.el b/lisp/shr-color.el
deleted file mode 100644
index 21f1fc4..0000000
--- a/lisp/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 <[email protected]>
-;; Keywords: html
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This package handles colors display for shr.
-
-;;; Code:
-
-(require 'color)
-(eval-when-compile (require 'cl))
-
-(defgroup shr-color nil
- "Simple HTML Renderer colors"
- :group 'shr)
-
-(defcustom shr-color-visible-luminance-min 40
- "Minimum luminance distance between two colors to be considered visible.
-Must be between 0 and 100."
- :group 'shr-color
- :type 'number)
-
-(defcustom shr-color-visible-distance-min 5
- "Minimum color distance between two colors to be considered visible.
-This value is used to compare result for `ciede2000'. It's an
-absolute value without any unit."
- :group 'shr-color
- :type 'integer)
-
-(defconst shr-color-html-colors-alist
- '(("AliceBlue" . "#F0F8FF")
- ("AntiqueWhite" . "#FAEBD7")
- ("Aqua" . "#00FFFF")
- ("Aquamarine" . "#7FFFD4")
- ("Azure" . "#F0FFFF")
- ("Beige" . "#F5F5DC")
- ("Bisque" . "#FFE4C4")
- ("Black" . "#000000")
- ("BlanchedAlmond" . "#FFEBCD")
- ("Blue" . "#0000FF")
- ("BlueViolet" . "#8A2BE2")
- ("Brown" . "#A52A2A")
- ("BurlyWood" . "#DEB887")
- ("CadetBlue" . "#5F9EA0")
- ("Chartreuse" . "#7FFF00")
- ("Chocolate" . "#D2691E")
- ("Coral" . "#FF7F50")
- ("CornflowerBlue" . "#6495ED")
- ("Cornsilk" . "#FFF8DC")
- ("Crimson" . "#DC143C")
- ("Cyan" . "#00FFFF")
- ("DarkBlue" . "#00008B")
- ("DarkCyan" . "#008B8B")
- ("DarkGoldenRod" . "#B8860B")
- ("DarkGray" . "#A9A9A9")
- ("DarkGrey" . "#A9A9A9")
- ("DarkGreen" . "#006400")
- ("DarkKhaki" . "#BDB76B")
- ("DarkMagenta" . "#8B008B")
- ("DarkOliveGreen" . "#556B2F")
- ("Darkorange" . "#FF8C00")
- ("DarkOrchid" . "#9932CC")
- ("DarkRed" . "#8B0000")
- ("DarkSalmon" . "#E9967A")
- ("DarkSeaGreen" . "#8FBC8F")
- ("DarkSlateBlue" . "#483D8B")
- ("DarkSlateGray" . "#2F4F4F")
- ("DarkSlateGrey" . "#2F4F4F")
- ("DarkTurquoise" . "#00CED1")
- ("DarkViolet" . "#9400D3")
- ("DeepPink" . "#FF1493")
- ("DeepSkyBlue" . "#00BFFF")
- ("DimGray" . "#696969")
- ("DimGrey" . "#696969")
- ("DodgerBlue" . "#1E90FF")
- ("FireBrick" . "#B22222")
- ("FloralWhite" . "#FFFAF0")
- ("ForestGreen" . "#228B22")
- ("Fuchsia" . "#FF00FF")
- ("Gainsboro" . "#DCDCDC")
- ("GhostWhite" . "#F8F8FF")
- ("Gold" . "#FFD700")
- ("GoldenRod" . "#DAA520")
- ("Gray" . "#808080")
- ("Grey" . "#808080")
- ("Green" . "#008000")
- ("GreenYellow" . "#ADFF2F")
- ("HoneyDew" . "#F0FFF0")
- ("HotPink" . "#FF69B4")
- ("IndianRed" . "#CD5C5C")
- ("Indigo" . "#4B0082")
- ("Ivory" . "#FFFFF0")
- ("Khaki" . "#F0E68C")
- ("Lavender" . "#E6E6FA")
- ("LavenderBlush" . "#FFF0F5")
- ("LawnGreen" . "#7CFC00")
- ("LemonChiffon" . "#FFFACD")
- ("LightBlue" . "#ADD8E6")
- ("LightCoral" . "#F08080")
- ("LightCyan" . "#E0FFFF")
- ("LightGoldenRodYellow" . "#FAFAD2")
- ("LightGray" . "#D3D3D3")
- ("LightGrey" . "#D3D3D3")
- ("LightGreen" . "#90EE90")
- ("LightPink" . "#FFB6C1")
- ("LightSalmon" . "#FFA07A")
- ("LightSeaGreen" . "#20B2AA")
- ("LightSkyBlue" . "#87CEFA")
- ("LightSlateGray" . "#778899")
- ("LightSlateGrey" . "#778899")
- ("LightSteelBlue" . "#B0C4DE")
- ("LightYellow" . "#FFFFE0")
- ("Lime" . "#00FF00")
- ("LimeGreen" . "#32CD32")
- ("Linen" . "#FAF0E6")
- ("Magenta" . "#FF00FF")
- ("Maroon" . "#800000")
- ("MediumAquaMarine" . "#66CDAA")
- ("MediumBlue" . "#0000CD")
- ("MediumOrchid" . "#BA55D3")
- ("MediumPurple" . "#9370D8")
- ("MediumSeaGreen" . "#3CB371")
- ("MediumSlateBlue" . "#7B68EE")
- ("MediumSpringGreen" . "#00FA9A")
- ("MediumTurquoise" . "#48D1CC")
- ("MediumVioletRed" . "#C71585")
- ("MidnightBlue" . "#191970")
- ("MintCream" . "#F5FFFA")
- ("MistyRose" . "#FFE4E1")
- ("Moccasin" . "#FFE4B5")
- ("NavajoWhite" . "#FFDEAD")
- ("Navy" . "#000080")
- ("OldLace" . "#FDF5E6")
- ("Olive" . "#808000")
- ("OliveDrab" . "#6B8E23")
- ("Orange" . "#FFA500")
- ("OrangeRed" . "#FF4500")
- ("Orchid" . "#DA70D6")
- ("PaleGoldenRod" . "#EEE8AA")
- ("PaleGreen" . "#98FB98")
- ("PaleTurquoise" . "#AFEEEE")
- ("PaleVioletRed" . "#D87093")
- ("PapayaWhip" . "#FFEFD5")
- ("PeachPuff" . "#FFDAB9")
- ("Peru" . "#CD853F")
- ("Pink" . "#FFC0CB")
- ("Plum" . "#DDA0DD")
- ("PowderBlue" . "#B0E0E6")
- ("Purple" . "#800080")
- ("Red" . "#FF0000")
- ("RosyBrown" . "#BC8F8F")
- ("RoyalBlue" . "#4169E1")
- ("SaddleBrown" . "#8B4513")
- ("Salmon" . "#FA8072")
- ("SandyBrown" . "#F4A460")
- ("SeaGreen" . "#2E8B57")
- ("SeaShell" . "#FFF5EE")
- ("Sienna" . "#A0522D")
- ("Silver" . "#C0C0C0")
- ("SkyBlue" . "#87CEEB")
- ("SlateBlue" . "#6A5ACD")
- ("SlateGray" . "#708090")
- ("SlateGrey" . "#708090")
- ("Snow" . "#FFFAFA")
- ("SpringGreen" . "#00FF7F")
- ("SteelBlue" . "#4682B4")
- ("Tan" . "#D2B48C")
- ("Teal" . "#008080")
- ("Thistle" . "#D8BFD8")
- ("Tomato" . "#FF6347")
- ("Turquoise" . "#40E0D0")
- ("Violet" . "#EE82EE")
- ("Wheat" . "#F5DEB3")
- ("White" . "#FFFFFF")
- ("WhiteSmoke" . "#F5F5F5")
- ("Yellow" . "#FFFF00")
- ("YellowGreen" . "#9ACD32"))
- "Alist of HTML colors.
-Each entry should have the form (COLOR-NAME . HEXADECIMAL-COLOR).")
-
-(defun shr-color-relative-to-absolute (number)
- "Convert a relative NUMBER to absolute.
-If NUMBER is absolute, return NUMBER.
-This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"."
- (let ((string-length (- (length number) 1)))
- ;; Is this a number with %?
- (if (eq (elt number string-length) ?%)
- (/ (* (string-to-number (substring number 0 string-length)) 255) 100)
- (string-to-number number))))
-
-(defun shr-color-hue-to-rgb (x y h)
- "Convert X Y H to RGB value."
- (when (< h 0) (incf h))
- (when (> h 1) (decf h))
- (cond ((< h (/ 1 6.0)) (+ x (* (- y x) h 6)))
- ((< h 0.5) y)
- ((< h (/ 2.0 3.0)) (+ x (* (- y x) (- (/ 2.0 3.0) h) 6)))
- (t x)))
-
-(defun shr-color-hsl-to-rgb-fractions (h s l)
- "Convert H S L to fractional RGB values."
- (let (m1 m2)
- (if (<= l 0.5)
- (setq m2 (* l (+ s 1)))
- (setq m2 (- (+ l s) (* l s))))
- (setq m1 (- (* l 2) m2))
- (list (shr-color-hue-to-rgb m1 m2 (+ h (/ 1 3.0)))
- (shr-color-hue-to-rgb m1 m2 h)
- (shr-color-hue-to-rgb m1 m2 (- h (/ 1 3.0))))))
-
-(defun shr-color->hexadecimal (color)
- "Convert any color format to hexadecimal representation.
-Like rgb() or hsl()."
- (when color
- (cond
- ;; Hexadecimal color: #abc or #aabbcc
- ((string-match
- "\\(#[0-9a-fA-F]\\{3\\}[0-9a-fA-F]\\{3\\}?\\)"
- color)
- (match-string 1 color))
- ;; rgb() or rgba() colors
- ((or (string-match
- "rgb(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*)"
- color)
- (string-match
- "rgba(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)"
- color))
- (format "#%02X%02X%02X"
- (shr-color-relative-to-absolute (match-string-no-properties 1 color))
- (shr-color-relative-to-absolute (match-string-no-properties 2 color))
- (shr-color-relative-to-absolute (match-string-no-properties 3 color))))
- ;; hsl() or hsla() colors
- ((or (string-match
- "hsl(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*)"
- color)
- (string-match
- "hsla(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)"
- color))
- (let ((h (/ (string-to-number (match-string-no-properties 1 color)) 360.0))
- (s (/ (string-to-number (match-string-no-properties 2 color)) 100.0))
- (l (/ (string-to-number (match-string-no-properties 3 color)) 100.0)))
- (destructuring-bind (r g b)
- (shr-color-hsl-to-rgb-fractions h s l)
- (color-rgb-to-hex r g b))))
- ;; Color names
- ((cdr (assoc-string color shr-color-html-colors-alist t)))
- ;; Unrecognized color :(
- (t
- nil))))
-
-(defun shr-color-set-minimum-interval (val1 val2 min max interval
- &optional fixed)
- "Set minimum interval between VAL1 and VAL2 to INTERVAL.
-The values are bound by MIN and MAX.
-If FIXED is t, then VAL1 will not be touched."
- (let ((diff (abs (- val1 val2))))
- (unless (>= diff interval)
- (if fixed
- (let* ((missing (- interval diff))
- ;; If val2 > val1, try to increase val2
- ;; That's the "good direction"
- (val2-good-direction
- (if (> val2 val1)
- (min max (+ val2 missing))
- (max min (- val2 missing))))
- (diff-val2-good-direction-val1 (abs (- val2-good-direction val1))))
- (if (>= diff-val2-good-direction-val1 interval)
- (setq val2 val2-good-direction)
- ;; Good-direction is not so good, compute bad-direction
- (let* ((val2-bad-direction
- (if (> val2 val1)
- (max min (- val1 interval))
- (min max (+ val1 interval))))
- (diff-val2-bad-direction-val1 (abs (- val2-bad-direction val1))))
- (if (>= diff-val2-bad-direction-val1 interval)
- (setq val2 val2-bad-direction)
- ;; Still not good, pick the best and prefer good direction
- (setq val2
- (if (>= diff-val2-good-direction-val1 diff-val2-bad-direction-val1)
- val2-good-direction
- val2-bad-direction))))))
- ;; No fixed, move val1 and val2
- (let ((missing (/ (- interval diff) 2.0)))
- (if (< val1 val2)
- (setq val1 (max min (- val1 missing))
- val2 (min max (+ val2 missing)))
- (setq val2 (max min (- val2 missing))
- val1 (min max (+ val1 missing))))
- (setq diff (abs (- val1 val2))) ; Recompute diff
- (unless (>= diff interval)
- ;; Not ok, we hit a boundary
- (let ((missing (- interval diff)))
- (cond ((= val1 min)
- (setq val2 (+ val2 missing)))
- ((= val2 min)
- (setq val1 (+ val1 missing)))
- ((= val1 max)
- (setq val2 (- val2 missing)))
- ((= val2 max)
- (setq val1 (- val1 missing)))))))))
- (list val1 val2)))
-
-(defun shr-color-visible (bg fg &optional fixed-background)
- "Check that BG and FG colors are visible if they are drawn on each other.
-Return (bg fg) if they are. If they are too similar, two new
-colors are returned instead.
-If FIXED-BACKGROUND is set, and if the color are not visible, a
-new background color will not be computed. Only the foreground
-color will be adapted to be visible on BG."
- ;; Convert fg and bg to CIE Lab
- (let ((fg-norm (color-name-to-rgb fg))
- (bg-norm (color-name-to-rgb bg)))
- (if (or (null fg-norm)
- (null bg-norm))
- (list bg fg)
- (let* ((fg-lab (apply 'color-srgb-to-lab fg-norm))
- (bg-lab (apply 'color-srgb-to-lab bg-norm))
- ;; Compute color distance using CIE DE 2000
- (fg-bg-distance (color-cie-de2000 fg-lab bg-lab))
- ;; Compute luminance distance (subtract L component)
- (luminance-distance (abs (- (car fg-lab) (car bg-lab)))))
- (if (and (>= fg-bg-distance shr-color-visible-distance-min)
- (>= luminance-distance shr-color-visible-luminance-min))
- (list bg fg)
- ;; Not visible, try to change luminance to make them visible
- (let ((Ls (shr-color-set-minimum-interval
- (car bg-lab) (car fg-lab) 0 100
- shr-color-visible-luminance-min fixed-background)))
- (unless fixed-background
- (setcar bg-lab (car Ls)))
- (setcar fg-lab (cadr Ls))
- (list
- (if fixed-background
- bg
- (apply 'format "#%02x%02x%02x"
- (mapcar (lambda (x) (* (max (min 1 x) 0) 255))
- (apply 'color-lab-to-srgb bg-lab))))
- (apply 'format "#%02x%02x%02x"
- (mapcar (lambda (x) (* (max (min 1 x) 0) 255))
- (apply 'color-lab-to-srgb fg-lab))))))))))
-
-(provide 'shr-color)
-
-;;; shr-color.el ends here
diff --git a/lisp/shr.el b/lisp/shr.el
deleted file mode 100644
index 868956d..0000000
--- a/lisp/shr.el
+++ /dev/null
@@ -1,1643 +0,0 @@
-;;; shr.el --- Simple HTML Renderer
-
-;; Copyright (C) 2010-2013 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <[email protected]>
-;; Keywords: html
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This package takes a HTML parse tree (as provided by
-;; libxml-parse-html-region) and renders it in the current buffer. It
-;; does not do CSS, JavaScript or anything advanced: It's geared
-;; towards rendering typical short snippets of HTML, like what you'd
-;; find in HTML email and the like.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(eval-when-compile (require 'url)) ;For url-filename's setf handler.
-(require 'browse-url)
-
-(defgroup shr nil
- "Simple HTML Renderer"
- :version "24.1"
- :group 'mail)
-
-(defcustom shr-max-image-proportion 0.9
- "How big pictures displayed are in relation to the window they're in.
-A value of 0.7 means that they are allowed to take up 70% of the
-width and height of the window. If they are larger than this,
-and Emacs supports it, then the images will be rescaled down to
-fit these criteria."
- :version "24.1"
- :group 'shr
- :type 'float)
-
-(defcustom shr-blocked-images nil
- "Images that have URLs matching this regexp will be blocked."
- :version "24.1"
- :group 'shr
- :type '(choice (const nil) regexp))
-
-(defcustom shr-table-horizontal-line nil
- "Character used to draw horizontal table lines.
-If nil, don't draw horizontal table lines."
- :group 'shr
- :type 'character)
-
-(defcustom shr-table-vertical-line ?\s
- "Character used to draw vertical table lines."
- :group 'shr
- :type 'character)
-
-(defcustom shr-table-corner ?\s
- "Character used to draw table corners."
- :group 'shr
- :type 'character)
-
-(defcustom shr-hr-line ?-
- "Character used to draw hr lines."
- :group 'shr
- :type 'character)
-
-(defcustom shr-width fill-column
- "Frame width to use for rendering.
-May either be an integer specifying a fixed width in characters,
-or nil, meaning that the full width of the window should be
-used."
- :type '(choice (integer :tag "Fixed width in characters")
- (const :tag "Use the width of the window" nil))
- :group 'shr)
-
-(defcustom shr-bullet "* "
- "Bullet used for unordered lists.
-Alternative suggestions are:
-- \" \"
-- \" \""
- :type 'string
- :group 'shr)
-
-(defvar shr-content-function nil
- "If bound, this should be a function that will return the content.
-This is used for cid: URLs, and the function is called with the
-cid: URL as the argument.")
-
-(defvar shr-put-image-function 'shr-put-image
- "Function called to put image and alt string.")
-
-(defface shr-strike-through '((t (:strike-through t)))
- "Font for <s> elements."
- :group 'shr)
-
-(defface shr-link
- '((t (:inherit link)))
- "Font for link elements."
- :group 'shr)
-
-;;; Internal variables.
-
-(defvar shr-folding-mode nil)
-(defvar shr-state nil)
-(defvar shr-start nil)
-(defvar shr-indentation 0)
-(defvar shr-inhibit-images nil)
-(defvar shr-list-mode nil)
-(defvar shr-content-cache nil)
-(defvar shr-kinsoku-shorten nil)
-(defvar shr-table-depth 0)
-(defvar shr-stylesheet nil)
-(defvar shr-base nil)
-(defvar shr-ignore-cache nil)
-(defvar shr-external-rendering-functions nil)
-(defvar shr-target-id nil)
-(defvar shr-inhibit-decoration nil)
-(defvar shr-table-separator-length 1)
-
-(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 [follow-link] 'mouse-face)
- (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 (1- (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)
- 'keymap shr-map)))
-
-(defun shr-encode-url (url)
- "Encode URL."
- (browse-url-url-encode-chars url "[)$ ]"))
-
-(autoload 'shr-color-visible "shr-color")
-(autoload 'shr-color->hexadecimal "shr-color")
-
-(defun shr-color-check (fg bg)
- "Check that FG is visible on BG.
-Returns (fg bg) with corrected values.
-Returns nil if the colors that would be used are the default
-ones, in case fg and bg are nil."
- (when (or fg bg)
- (let ((fixed (cond ((null fg) 'fg)
- ((null bg) 'bg))))
- ;; Convert colors to hexadecimal, or set them to default.
- (let ((fg (or (shr-color->hexadecimal fg)
- (frame-parameter nil 'foreground-color)))
- (bg (or (shr-color->hexadecimal bg)
- (frame-parameter nil 'background-color))))
- (cond ((eq fixed 'bg)
- ;; Only return the new fg
- (list nil (cadr (shr-color-visible bg fg t))))
- ((eq fixed 'fg)
- ;; Invert args and results and return only the new bg
- (list (cadr (shr-color-visible fg bg t)) nil))
- (t
- (shr-color-visible bg fg)))))))
-
-(defun shr-colorize-region (start end fg &optional bg)
- (when (and (not shr-inhibit-decoration)
- (or fg bg))
- (let ((new-colors (shr-color-check fg bg)))
- (when new-colors
- (when fg
- (add-face-text-property start end
- (list :foreground (cadr new-colors))
- t))
- (when bg
- (add-face-text-property start end
- (list :background (car new-colors))
- t)))
- new-colors)))
-
-(defun shr-expand-newlines (start end color)
- (save-restriction
- ;; Skip past all white space at the start and ends.
- (goto-char start)
- (skip-chars-forward " \t\n")
- (beginning-of-line)
- (setq start (point))
- (goto-char end)
- (skip-chars-backward " \t\n")
- (forward-line 1)
- (setq end (point))
- (narrow-to-region start end)
- (let ((width (shr-buffer-width))
- column)
- (goto-char (point-min))
- (while (not (eobp))
- (end-of-line)
- (when (and (< (setq column (current-column)) width)
- (< (setq column (shr-previous-newline-padding-width column))
- width))
- (let ((overlay (make-overlay (point) (1+ (point)))))
- (overlay-put overlay 'before-string
- (concat
- (mapconcat
- (lambda (overlay)
- (let ((string (plist-get
- (overlay-properties overlay)
- 'before-string)))
- (if (not string)
- ""
- (overlay-put overlay 'before-string "")
- string)))
- (overlays-at (point))
- "")
- (propertize (make-string (- width column) ? )
- 'face (list :background color))))))
- (forward-line 1)))))
-
-(defun shr-previous-newline-padding-width (width)
- (let ((overlays (overlays-at (point)))
- (previous-width 0))
- (if (null overlays)
- width
- (dolist (overlay overlays)
- (setq previous-width
- (+ previous-width
- (length (plist-get (overlay-properties overlay)
- 'before-string)))))
- (+ width previous-width))))
-
-;;; Tag-specific rendering rules.
-
-(defun shr-tag-body (cont)
- (let* ((start (point))
- (fgcolor (cdr (or (assq :fgcolor cont)
- (assq :text cont))))
- (bgcolor (cdr (assq :bgcolor cont)))
- (shr-stylesheet (list (cons 'color fgcolor)
- (cons 'background-color bgcolor))))
- (shr-generic cont)
- (shr-colorize-region start (point) fgcolor bgcolor)))
-
-(defun shr-tag-style (cont)
- )
-
-(defun shr-tag-script (cont)
- )
-
-(defun shr-tag-comment (cont)
- )
-
-(defun shr-dom-to-xml (dom)
- "Convert DOM into a string containing the xml representation."
- (let ((arg " ")
- (text ""))
- (dolist (sub (cdr dom))
- (cond
- ((listp (cdr sub))
- (setq text (concat text (shr-dom-to-xml sub))))
- ((eq (car sub) 'text)
- (setq text (concat text (cdr sub))))
- (t
- (setq arg (concat arg (format "%s=\"%s\" "
- (substring (symbol-name (car sub)) 1)
- (cdr sub)))))))
- (format "<%s%s>%s</%s>"
- (car dom)
- (substring arg 0 (1- (length arg)))
- text
- (car dom))))
-
-(defun shr-tag-svg (cont)
- (when (image-type-available-p 'svg)
- (funcall shr-put-image-function
- (shr-dom-to-xml (cons 'svg cont))
- "SVG Image")))
-
-(defun shr-tag-sup (cont)
- (let ((start (point)))
- (shr-generic cont)
- (put-text-property start (point) 'display '(raise 0.5))))
-
-(defun shr-tag-sub (cont)
- (let ((start (point)))
- (shr-generic cont)
- (put-text-property start (point) 'display '(raise -0.5))))
-
-(defun shr-tag-label (cont)
- (shr-generic cont)
- (shr-ensure-paragraph))
-
-(defun shr-tag-p (cont)
- (shr-ensure-paragraph)
- (shr-indent)
- (shr-generic cont)
- (shr-ensure-paragraph))
-
-(defun shr-tag-div (cont)
- (shr-ensure-newline)
- (shr-indent)
- (shr-generic cont)
- (shr-ensure-newline))
-
-(defun shr-tag-s (cont)
- (shr-fontize-cont cont 'shr-strike-through))
-
-(defun shr-tag-del (cont)
- (shr-fontize-cont cont 'shr-strike-through))
-
-(defun shr-tag-b (cont)
- (shr-fontize-cont cont 'bold))
-
-(defun shr-tag-i (cont)
- (shr-fontize-cont cont 'italic))
-
-(defun shr-tag-em (cont)
- (shr-fontize-cont cont 'italic))
-
-(defun shr-tag-strong (cont)
- (shr-fontize-cont cont 'bold))
-
-(defun shr-tag-u (cont)
- (shr-fontize-cont cont 'underline))
-
-(defun shr-parse-style (style)
- (when style
- (save-match-data
- (when (string-match "\n" style)
- (setq style (replace-match " " t t style))))
- (let ((plist nil))
- (dolist (elem (split-string style ";"))
- (when elem
- (setq elem (split-string elem ":"))
- (when (and (car elem)
- (cadr elem))
- (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem)))
- (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem))))
- (when (string-match " *!important\\'" value)
- (setq value (substring value 0 (match-beginning 0))))
- (push (cons (intern name obarray)
- value)
- plist)))))
- plist)))
-
-(defun shr-tag-base (cont)
- (let ((base (cdr (assq :href cont))))
- (when base
- (setq shr-base (shr-parse-base base))))
- (shr-generic cont))
-
-(defun shr-tag-a (cont)
- (let ((url (cdr (assq :href cont)))
- (title (cdr (assq :title cont)))
- (start (point))
- shr-start)
- (shr-generic cont)
- (when (and url
- (not shr-inhibit-decoration))
- (shr-urlify (or shr-start start) (shr-expand-url url) title))))
-
-(defun shr-tag-object (cont)
- (let ((start (point))
- url)
- (dolist (elem cont)
- (when (eq (car elem) 'embed)
- (setq url (or url (cdr (assq :src (cdr elem))))))
- (when (and (eq (car elem) 'param)
- (equal (cdr (assq :name (cdr elem))) "movie"))
- (setq url (or url (cdr (assq :value (cdr elem)))))))
- (when url
- (shr-insert " [multimedia] ")
- (shr-urlify start (shr-expand-url url)))
- (shr-generic cont)))
-
-(defun shr-tag-video (cont)
- (let ((image (cdr (assq :poster cont)))
- (url (cdr (assq :src cont)))
- (start (point)))
- (shr-tag-img nil image)
- (shr-urlify start (shr-expand-url url))))
-
-(defun shr-tag-img (cont &optional url)
- (when (or url
- (and cont
- (cdr (assq :src cont))))
- (when (and (> (current-column) 0)
- (not (eq shr-state 'image)))
- (insert "\n"))
- (let ((alt (cdr (assq :alt cont)))
- (url (shr-expand-url (or url (cdr (assq :src cont))))))
- (let ((start (point-marker)))
- (when (zerop (length alt))
- (setq alt "*"))
- (cond
- ((or (member (cdr (assq :height cont)) '("0" "1"))
- (member (cdr (assq :width cont)) '("0" "1")))
- ;; Ignore zero-sized or single-pixel images.
- )
- ((and (not shr-inhibit-images)
- (string-match "\\`data:" url))
- (let ((image (shr-image-from-data (substring url (match-end 0)))))
- (if image
- (funcall shr-put-image-function image alt)
- (insert alt))))
- ((and (not shr-inhibit-images)
- (string-match "\\`cid:" url))
- (let ((url (substring url (match-end 0)))
- image)
- (if (or (not shr-content-function)
- (not (setq image (funcall shr-content-function url))))
- (insert alt)
- (funcall shr-put-image-function image alt))))
- ((or shr-inhibit-images
- (and shr-blocked-images
- (string-match shr-blocked-images url)))
- (setq shr-start (point))
- (let ((shr-state 'space))
- (if (> (string-width alt) 8)
- (shr-insert (truncate-string-to-width alt 8))
- (shr-insert alt))))
- ((and (not shr-ignore-cache)
- (url-is-cached (shr-encode-url url)))
- (funcall shr-put-image-function (shr-get-image-data url) alt))
- (t
- (insert alt " ")
- (when (and shr-ignore-cache
- (url-is-cached (shr-encode-url url)))
- (let ((file (url-cache-create-filename (shr-encode-url url))))
- (when (file-exists-p file)
- (delete-file file))))
- (url-queue-retrieve
- (shr-encode-url url) 'shr-image-fetched
- (list (current-buffer) start (set-marker (make-marker) (1- (point))))
- t t)))
- (when (zerop shr-table-depth) ;; We are not in a table.
- (put-text-property start (point) 'keymap shr-map)
- (put-text-property start (point) 'shr-alt alt)
- (put-text-property start (point) 'image-url url)
- (put-text-property start (point) 'image-displayer
- (shr-image-displayer shr-content-function))
- (put-text-property start (point) 'help-echo alt))
- (setq shr-state 'image)))))
-
-(defun shr-tag-pre (cont)
- (let ((shr-folding-mode 'none))
- (shr-ensure-newline)
- (shr-indent)
- (shr-generic cont)
- (shr-ensure-newline)))
-
-(defun shr-tag-blockquote (cont)
- (shr-ensure-paragraph)
- (shr-indent)
- (let ((shr-indentation (+ shr-indentation 4)))
- (shr-generic cont))
- (shr-ensure-paragraph))
-
-(defun shr-tag-dl (cont)
- (shr-ensure-paragraph)
- (shr-generic cont)
- (shr-ensure-paragraph))
-
-(defun shr-tag-dt (cont)
- (shr-ensure-newline)
- (shr-generic cont)
- (shr-ensure-newline))
-
-(defun shr-tag-dd (cont)
- (shr-ensure-newline)
- (let ((shr-indentation (+ shr-indentation 4)))
- (shr-generic cont)))
-
-(defun shr-tag-ul (cont)
- (shr-ensure-paragraph)
- (let ((shr-list-mode 'ul))
- (shr-generic cont))
- (shr-ensure-paragraph))
-
-(defun shr-tag-ol (cont)
- (shr-ensure-paragraph)
- (let ((shr-list-mode 1))
- (shr-generic cont))
- (shr-ensure-paragraph))
-
-(defun shr-tag-li (cont)
- (shr-ensure-newline)
- (shr-indent)
- (let* ((bullet
- (if (numberp shr-list-mode)
- (prog1
- (format "%d " shr-list-mode)
- (setq shr-list-mode (1+ shr-list-mode)))
- shr-bullet))
- (shr-indentation (+ shr-indentation (length bullet))))
- (insert bullet)
- (shr-generic cont)))
-
-(defun shr-tag-br (cont)
- (when (and (not (bobp))
- ;; Only add a newline if we break the current line, or
- ;; the previous line isn't a blank line.
- (or (not (bolp))
- (and (> (- (point) 2) (point-min))
- (not (= (char-after (- (point) 2)) ?\n)))))
- (insert "\n")
- (shr-indent))
- (shr-generic cont))
-
-(defun shr-tag-span (cont)
- (shr-generic cont))
-
-(defun shr-tag-h1 (cont)
- (shr-heading cont 'bold 'underline))
-
-(defun shr-tag-h2 (cont)
- (shr-heading cont 'bold))
-
-(defun shr-tag-h3 (cont)
- (shr-heading cont 'italic))
-
-(defun shr-tag-h4 (cont)
- (shr-heading cont))
-
-(defun shr-tag-h5 (cont)
- (shr-heading cont))
-
-(defun shr-tag-h6 (cont)
- (shr-heading cont))
-
-(defun shr-tag-hr (cont)
- (shr-ensure-newline)
- (insert (make-string shr-width shr-hr-line) "\n"))
-
-(defun shr-tag-title (cont)
- (shr-heading cont 'bold 'underline))
-
-(defun shr-tag-font (cont)
- (let* ((start (point))
- (color (cdr (assq :color cont)))
- (shr-stylesheet (nconc (list (cons 'color color))
- shr-stylesheet)))
- (shr-generic cont)
- (when color
- (shr-colorize-region start (point) color
- (cdr (assq 'background-color shr-stylesheet))))))
-
-;;; Table rendering algorithm.
-
-;; Table rendering is the only complicated thing here. We do this by
-;; first counting how many TDs there are in each TR, and registering
-;; how wide they think they should be ("width=45%", etc). Then we
-;; render each TD separately (this is done in temporary buffers, so
-;; that we can use all the rendering machinery as if we were in the
-;; main buffer). Now we know how much space each TD really takes, so
-;; we then render everything again with the new widths, and finally
-;; insert all these boxes into the main buffer.
-(defun shr-tag-table-1 (cont)
- (setq cont (or (cdr (assq 'tbody cont))
- cont))
- (let* ((shr-inhibit-images t)
- (shr-table-depth (1+ shr-table-depth))
- (shr-kinsoku-shorten t)
- ;; Find all suggested widths.
- (columns (shr-column-specs cont))
- ;; Compute how many characters wide each TD should be.
- (suggested-widths (shr-pro-rate-columns columns))
- ;; Do a "test rendering" to see how big each TD is (this can
- ;; be smaller (if there's little text) or bigger (if there's
- ;; unbreakable text).
- (sketch (shr-make-table cont suggested-widths))
- ;; Compute the "natural" width by setting each column to 500
- ;; characters and see how wide they really render.
- (natural (shr-make-table cont (make-vector (length columns) 500)))
- (sketch-widths (shr-table-widths sketch natural suggested-widths)))
- ;; This probably won't work very well.
- (when (> (+ (loop for width across sketch-widths
- summing (1+ width))
- shr-indentation 1)
- (frame-width))
- (setq truncate-lines t))
- ;; Then render the table again with these new "hard" widths.
- (shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths)))
-
-(defun shr-tag-table (cont)
- (shr-ensure-paragraph)
- (let* ((caption (cdr (assq 'caption cont)))
- (header (cdr (assq 'thead cont)))
- (body (or (cdr (assq 'tbody cont)) cont))
- (footer (cdr (assq 'tfoot cont)))
- (bgcolor (cdr (assq :bgcolor cont)))
- (start (point))
- (shr-stylesheet (nconc (list (cons 'background-color bgcolor))
- shr-stylesheet))
- (nheader (if header (shr-max-columns header)))
- (nbody (if body (shr-max-columns body)))
- (nfooter (if footer (shr-max-columns footer))))
- (if (and (not caption)
- (not header)
- (not (cdr (assq 'tbody cont)))
- (not (cdr (assq 'tr cont)))
- (not footer))
- ;; The table is totally invalid and just contains random junk.
- ;; Try to output it anyway.
- (shr-generic cont)
- ;; It's a real table, so render it.
- (shr-tag-table-1
- (nconc
- (if caption `((tr (td ,@caption))))
- (if header
- (if footer
- ;; hader + body + footer
- (if (= nheader nbody)
- (if (= nbody nfooter)
- `((tr (td (table (tbody ,@header ,@body ,@footer)))))
- (nconc `((tr (td (table (tbody ,@header ,@body)))))
- (if (= nfooter 1)
- footer
- `((tr (td (table (tbody ,@footer))))))))
- (nconc `((tr (td (table (tbody ,@header)))))
- (if (= nbody nfooter)
- `((tr (td (table (tbody ,@body ,@footer)))))
- (nconc `((tr (td (table (tbody ,@body)))))
- (if (= nfooter 1)
- footer
- `((tr (td (table (tbody ,@footer))))))))))
- ;; header + body
- (if (= nheader nbody)
- `((tr (td (table (tbody ,@header ,@body)))))
- (if (= nheader 1)
- `(,@header (tr (td (table (tbody ,@body)))))
- `((tr (td (table (tbody ,@header))))
- (tr (td (table (tbody ,@body))))))))
- (if footer
- ;; body + footer
- (if (= nbody nfooter)
- `((tr (td (table (tbody ,@body ,@footer)))))
- (nconc `((tr (td (table (tbody ,@body)))))
- (if (= nfooter 1)
- footer
- `((tr (td (table (tbody ,@footer))))))))
- (if caption
- `((tr (td (table (tbody ,@body)))))
- body))))))
- (when bgcolor
- (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
- bgcolor))
- ;; Finally, insert all the images after the table. The Emacs buffer
- ;; model isn't strong enough to allow us to put the images actually
- ;; into the tables.
- (when (zerop shr-table-depth)
- (dolist (elem (shr-find-elements cont 'img))
- (shr-tag-img (cdr elem))))))
-
-(defun shr-find-elements (cont type)
- (let (result)
- (dolist (elem cont)
- (cond ((eq (car elem) type)
- (push elem result))
- ((consp (cdr elem))
- (setq result (nconc (shr-find-elements (cdr elem) type) result)))))
- (nreverse result)))
-
-(defun shr-insert-table (table widths)
- (let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet))
- "collapse"))
- (shr-table-separator-length (if collapse 0 1))
- (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 shr-table-horizontal-line
- (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))
- (rowspans (make-vector (length widths) 0))
- width colspan)
- (dolist (row cont)
- (when (eq (car row) 'tr)
- (let ((tds nil)
- (columns (cdr row))
- (i 0)
- (width-column 0)
- column)
- (while (< i (length widths))
- ;; If we previously had a rowspan definition, then that
- ;; means that we now have a "missing" td/th element here.
- ;; So just insert a dummy, empty one to (sort of) emulate
- ;; rowspan.
- (setq column
- (if (zerop (aref rowspans i))
- (pop columns)
- (aset rowspans i (1- (aref rowspans i)))
- '(td)))
- (when (or (memq (car column) '(td th))
- (not column))
- (when (cdr (assq :rowspan (cdr column)))
- (aset rowspans i (+ (aref rowspans i)
- (1- (string-to-number
- (cdr (assq :rowspan (cdr column))))))))
- ;; Sanity check for invalid column-spans.
- (when (>= width-column (length widths))
- (setq width-column 0))
- (setq width
- (if column
- (aref widths width-column)
- 0))
- (when (and fill
- (setq colspan (cdr (assq :colspan (cdr column)))))
- (setq colspan (string-to-number colspan))
- (dotimes (j (1- colspan))
- (if (> (+ i 1 j) (1- (length widths)))
- (setq width (aref widths (1- (length widths))))
- (setq width (+ width
- shr-table-separator-length
- (aref widths (+ i 1 j))))))
- (setq width-column (+ width-column (1- colspan))))
- (when (or column
- (not fill))
- (push (shr-render-td (cdr column) width fill)
- tds))
- (setq i (1+ i)
- width-column (1+ width-column))))
- (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
-----------------------------------------------------------------------
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we listed those
revisions in full, above.
Summary of changes:
lisp/ChangeLog | 5 +
lisp/dgnushack.el | 2 +-
lisp/eww.el | 815 --------------------------
lisp/shr-color.el | 363 ------------
lisp/shr.el | 1643 -----------------------------------------------------
5 files changed, 6 insertions(+), 2822 deletions(-)
delete mode 100644 lisp/eww.el
delete mode 100644 lisp/shr-color.el
delete mode 100644 lisp/shr.el
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "Gnus Project".
The branch, master has been updated
hooks/post-receive
--
Gnus Project