Commit be2aa135 authored by Lars Magne Ingebrigtsen's avatar Lars Magne Ingebrigtsen Committed by Katsumi Yamaoka
Browse files

lisp/gnus/{eww,shr}.el: Merge changes made in Gnus master

lisp/gnus/eww.el (eww-tag-select): Don't render totally empty <select> forms.
(eww-convert-widgets): Don't bug out if the first widget starts at the beginning of the buffer.
(eww-convert-widgets): Fix last patch.

lisp/gnus/shr.el (shr-insert-table): Respect border-collapse: collapse.
(shr-tag-base): Protect against base specs that are degenerate.
(shr-ensure-paragraph): Don't delete empty lines that have text properties, because these may be input fields.

lisp/gnus/eww.el (eww-convert-widgets): Put `help-echo' on input fields so that we can navigate to them.

lisp/gnus/shr.el (shr-colorize-region): Put the colours over the entire region.
(shr-inhibit-decoration): New variable.
(shr-add-font): Use it to inhibit text property decorations while doing preliminary table renderings.  This speeds up typical Wikipedia page renderings by 15%.
(shr-tag-span): Don't respect the <title>, because that overwrites the help-echo from links inside the spans.
(shr-next-link): Use `help-echo' for navigation, so that we can navigate to form elements, too.

lisp/gnus/eww.el (eww-button): New face.
(eww-convert-widgets): Use it to make submit buttons more button-like.
parent ec6ecaad
2013-06-17 Lars Magne Ingebrigtsen <larsi@gnus.org> 2013-06-17 Lars Magne Ingebrigtsen <larsi@gnus.org>
   
* eww.el (eww-tag-select): Don't render totally empty <select> forms.
(eww-convert-widgets): Don't bug out if the first widget starts at the
beginning of the buffer.
(eww-convert-widgets): Fix last patch.
* shr.el (shr-insert-table): Respect border-collapse: collapse.
(shr-tag-base): Protect against base specs that are degenerate.
(shr-ensure-paragraph): Don't delete empty lines that have text
properties, because these may be input fields.
* eww.el (eww-convert-widgets): Put `help-echo' on input fields so that
we can navigate to them.
* shr.el (shr-colorize-region): Put the colours over the entire region.
(shr-inhibit-decoration): New variable.
(shr-add-font): Use it to inhibit text property decorations while doing
preliminary table renderings. This speeds up typical Wikipedia page
renderings by 15%.
(shr-tag-span): Don't respect the <title>, because that overwrites the
help-echo from links inside the spans.
(shr-next-link): Use `help-echo' for navigation, so that we can
navigate to form elements, too.
* eww.el (eww-button): New face.
(eww-convert-widgets): Use it to make submit buttons more button-like.
* mm-decode.el (mm-convert-shr-links): Override the shr local map, so * mm-decode.el (mm-convert-shr-links): Override the shr local map, so
that Gnus commands work. that Gnus commands work.
   
......
...@@ -43,6 +43,14 @@ ...@@ -43,6 +43,14 @@
:group 'eww :group 'eww
:type 'string) :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-url nil)
(defvar eww-current-title "" (defvar eww-current-title ""
"Title of current page.") "Title of current page.")
...@@ -268,34 +276,39 @@ ...@@ -268,34 +276,39 @@
(let* ((start (point)) (let* ((start (point))
(type (downcase (or (cdr (assq :type cont)) (type (downcase (or (cdr (assq :type cont))
"text"))) "text")))
(value (cdr (assq :value cont)))
(widget (widget
(cond (cond
((equal type "submit") ((equal type "submit")
(list 'push-button (list 'push-button
:notify 'eww-submit :notify 'eww-submit
:name (cdr (assq :name cont)) :name (cdr (assq :name cont))
:value (cdr (assq :value cont)) :value (if (zerop (length value))
"Submit"
value)
:eww-form eww-form :eww-form eww-form
(or (cdr (assq :value cont)) "Submit"))) (or (if (zerop (length value))
"Submit"
value))))
((or (equal type "radio") ((or (equal type "radio")
(equal type "checkbox")) (equal type "checkbox"))
(list 'checkbox (list 'checkbox
:notify 'eww-click-radio :notify 'eww-click-radio
:name (cdr (assq :name cont)) :name (cdr (assq :name cont))
:checkbox-value (cdr (assq :value cont)) :checkbox-value value
:checkbox-type type :checkbox-type type
:eww-form eww-form :eww-form eww-form
(cdr (assq :checked cont)))) (cdr (assq :checked cont))))
((equal type "hidden") ((equal type "hidden")
(list 'hidden (list 'hidden
:name (cdr (assq :name cont)) :name (cdr (assq :name cont))
:value (cdr (assq :value cont)))) :value value))
(t (t
(list 'editable-field (list 'editable-field
:size (string-to-number :size (string-to-number
(or (cdr (assq :size cont)) (or (cdr (assq :size cont))
"40")) "40"))
:value (or (cdr (assq :value cont)) "") :value (or value "")
:secret (and (equal type "password") ?*) :secret (and (equal type "password") ?*)
:action 'eww-submit :action 'eww-submit
:name (cdr (assq :name cont)) :name (cdr (assq :name cont))
...@@ -303,7 +316,8 @@ ...@@ -303,7 +316,8 @@
(nconc eww-form (list widget)) (nconc eww-form (list widget))
(unless (eq (car widget) 'hidden) (unless (eq (car widget) 'hidden)
(apply 'widget-create widget) (apply 'widget-create widget)
(put-text-property start (point) 'eww-widget widget)))) (put-text-property start (point) 'eww-widget widget)
(insert " "))))
(defun eww-tag-textarea (cont) (defun eww-tag-textarea (cont)
(let* ((start (point)) (let* ((start (point))
...@@ -336,13 +350,14 @@ ...@@ -336,13 +350,14 @@
:value (cdr (assq :value (cdr elem))) :value (cdr (assq :value (cdr elem)))
:tag (cdr (assq 'text (cdr elem)))) :tag (cdr (assq 'text (cdr elem))))
options))) options)))
;; If we have no selected values, default to the first value. (when options
(unless (plist-get (cdr menu) :value) ;; If we have no selected values, default to the first value.
(nconc menu (list :value (nth 2 (car options))))) (unless (plist-get (cdr menu) :value)
(nconc menu options) (nconc menu (list :value (nth 2 (car options)))))
(apply 'widget-create menu) (nconc menu options)
(put-text-property start (point) 'eww-widget menu) (apply 'widget-create menu)
(shr-ensure-paragraph))) (put-text-property start (point) 'eww-widget menu)
(shr-ensure-paragraph))))
(defun eww-click-radio (widget &rest ignore) (defun eww-click-radio (widget &rest ignore)
(let ((form (plist-get (cdr widget) :eww-form)) (let ((form (plist-get (cdr widget) :eww-form))
...@@ -434,7 +449,9 @@ ...@@ -434,7 +449,9 @@
;; so we need to nix out the list of widgets and recreate them. ;; so we need to nix out the list of widgets and recreate them.
(setq widget-field-list nil (setq widget-field-list nil
widget-field-new nil) widget-field-new nil)
(while (setq start (next-single-property-change start 'eww-widget)) (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)) (setq widget (get-text-property start 'eww-widget))
(goto-char start) (goto-char start)
(let ((end (next-single-property-change start 'eww-widget))) (let ((end (next-single-property-change start 'eww-widget)))
...@@ -445,7 +462,13 @@ ...@@ -445,7 +462,13 @@
(delete-region start end)) (delete-region start end))
(when (and widget (when (and widget
(not (eq (car widget) 'hidden))) (not (eq (car widget) 'hidden)))
(apply 'widget-create widget))) (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) (widget-setup)
(eww-fix-widget-keymap))) (eww-fix-widget-keymap)))
......
...@@ -125,6 +125,7 @@ cid: URL as the argument.") ...@@ -125,6 +125,7 @@ cid: URL as the argument.")
(defvar shr-ignore-cache nil) (defvar shr-ignore-cache nil)
(defvar shr-external-rendering-functions nil) (defvar shr-external-rendering-functions nil)
(defvar shr-target-id nil) (defvar shr-target-id nil)
(defvar shr-inhibit-decoration nil)
(defvar shr-map (defvar shr-map
(let ((map (make-sparse-keymap))) (let ((map (make-sparse-keymap)))
...@@ -222,9 +223,9 @@ redirects somewhere else." ...@@ -222,9 +223,9 @@ redirects somewhere else."
(defun shr-next-link () (defun shr-next-link ()
"Skip to the next link." "Skip to the next link."
(interactive) (interactive)
(let ((skip (text-property-any (point) (point-max) 'shr-url nil))) (let ((skip (text-property-any (point) (point-max) 'help-echo nil)))
(if (not (setq skip (text-property-not-all skip (point-max) (if (not (setq skip (text-property-not-all skip (point-max)
'shr-url nil))) 'help-echo nil)))
(message "No next link") (message "No next link")
(goto-char skip) (goto-char skip)
(message "%s" (get-text-property (point) 'help-echo))))) (message "%s" (get-text-property (point) 'help-echo)))))
...@@ -236,11 +237,11 @@ redirects somewhere else." ...@@ -236,11 +237,11 @@ redirects somewhere else."
(found nil)) (found nil))
;; Skip past the current link. ;; Skip past the current link.
(while (and (not (bobp)) (while (and (not (bobp))
(get-text-property (point) 'shr-url)) (get-text-property (point) 'help-echo))
(forward-char -1)) (forward-char -1))
;; Find the previous link. ;; Find the previous link.
(while (and (not (bobp)) (while (and (not (bobp))
(not (setq found (get-text-property (point) 'shr-url)))) (not (setq found (get-text-property (point) 'help-echo))))
(forward-char -1)) (forward-char -1))
(if (not found) (if (not found)
(progn (progn
...@@ -248,7 +249,7 @@ redirects somewhere else." ...@@ -248,7 +249,7 @@ redirects somewhere else."
(goto-char start)) (goto-char start))
;; Put point at the start of the link. ;; Put point at the start of the link.
(while (and (not (bobp)) (while (and (not (bobp))
(get-text-property (point) 'shr-url)) (get-text-property (point) 'help-echo))
(forward-char -1)) (forward-char -1))
(forward-char 1) (forward-char 1)
(message "%s" (get-text-property (point) 'help-echo))))) (message "%s" (get-text-property (point) 'help-echo)))))
...@@ -349,7 +350,7 @@ size, and full-buffer size." ...@@ -349,7 +350,7 @@ size, and full-buffer size."
(shr-stylesheet shr-stylesheet) (shr-stylesheet shr-stylesheet)
(start (point))) (start (point)))
(when style (when style
(if (string-match "color\\|display" style) (if (string-match "color\\|display\\|border-collapse" style)
(setq shr-stylesheet (nconc (shr-parse-style style) (setq shr-stylesheet (nconc (shr-parse-style style)
shr-stylesheet)) shr-stylesheet))
(setq style nil))) (setq style nil)))
...@@ -595,7 +596,14 @@ size, and full-buffer size." ...@@ -595,7 +596,14 @@ size, and full-buffer size."
(insert "\n")) (insert "\n"))
(if (save-excursion (if (save-excursion
(beginning-of-line) (beginning-of-line)
(looking-at " *$")) ;; 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)) (delete-region (match-beginning 0) (match-end 0))
(insert "\n\n"))))) (insert "\n\n")))))
...@@ -613,15 +621,16 @@ size, and full-buffer size." ...@@ -613,15 +621,16 @@ size, and full-buffer size."
;; blank text at the start of the line, and the newline at the end, to ;; blank text at the start of the line, and the newline at the end, to
;; avoid ugliness. ;; avoid ugliness.
(defun shr-add-font (start end type) (defun shr-add-font (start end type)
(save-excursion (unless shr-inhibit-decoration
(goto-char start) (save-excursion
(while (< (point) end) (goto-char start)
(when (bolp) (while (< (point) end)
(skip-chars-forward " ")) (when (bolp)
(add-face-text-property (point) (min (line-end-position) end) type t) (skip-chars-forward " "))
(if (< (line-end-position) end) (add-face-text-property (point) (min (line-end-position) end) type t)
(forward-line 1) (if (< (line-end-position) end)
(goto-char end))))) (forward-line 1)
(goto-char end))))))
(defun shr-browse-url () (defun shr-browse-url ()
"Browse the URL under point." "Browse the URL under point."
...@@ -797,12 +806,13 @@ START, and END. Note that START and END should be markers." ...@@ -797,12 +806,13 @@ START, and END. Note that START and END should be markers."
(shr-ensure-paragraph)) (shr-ensure-paragraph))
(defun shr-urlify (start url &optional title) (defun shr-urlify (start url &optional title)
(when (and title (string-match "ctx" title)) (debug))
(shr-add-font start (point) 'shr-link) (shr-add-font start (point) 'shr-link)
(add-text-properties (add-text-properties
start (point) start (point)
(list 'shr-url url (list 'shr-url url
'local-map shr-map 'help-echo (if title (format "%s (%s)" url title) url)
'help-echo (if title (format "%s (%s)" url title) url)))) 'local-map shr-map)))
(defun shr-encode-url (url) (defun shr-encode-url (url)
"Encode URL." "Encode URL."
...@@ -834,13 +844,18 @@ ones, in case fg and bg are nil." ...@@ -834,13 +844,18 @@ ones, in case fg and bg are nil."
(shr-color-visible bg fg))))))) (shr-color-visible bg fg)))))))
(defun shr-colorize-region (start end fg &optional bg) (defun shr-colorize-region (start end fg &optional bg)
(when (or fg bg) (when (and (not shr-inhibit-decoration)
(or fg bg))
(let ((new-colors (shr-color-check fg bg))) (let ((new-colors (shr-color-check fg bg)))
(when new-colors (when new-colors
(when fg (when fg
(shr-add-font start end (list :foreground (cadr new-colors)))) (add-face-text-property start end
(list :foreground (cadr new-colors))
t))
(when bg (when bg
(shr-add-font start end (list :background (car new-colors))))) (add-face-text-property start end
(list :background (car new-colors))
t)))
new-colors))) new-colors)))
(defun shr-expand-newlines (start end color) (defun shr-expand-newlines (start end color)
...@@ -1008,7 +1023,9 @@ ones, in case fg and bg are nil." ...@@ -1008,7 +1023,9 @@ ones, in case fg and bg are nil."
plist))) plist)))
(defun shr-tag-base (cont) (defun shr-tag-base (cont)
(setq shr-base (shr-parse-base (cdr (assq :href cont)))) (let ((base (cdr (assq :href cont))))
(when base
(setq shr-base (shr-parse-base base))))
(shr-generic cont)) (shr-generic cont))
(defun shr-tag-a (cont) (defun shr-tag-a (cont)
...@@ -1017,7 +1034,8 @@ ones, in case fg and bg are nil." ...@@ -1017,7 +1034,8 @@ ones, in case fg and bg are nil."
(start (point)) (start (point))
shr-start) shr-start)
(shr-generic cont) (shr-generic cont)
(when url (when (and url
(not shr-inhibit-decoration))
(shr-urlify (or shr-start start) (shr-expand-url url) title)))) (shr-urlify (or shr-start start) (shr-expand-url url) title))))
(defun shr-tag-object (cont) (defun shr-tag-object (cont)
...@@ -1154,11 +1172,7 @@ ones, in case fg and bg are nil." ...@@ -1154,11 +1172,7 @@ ones, in case fg and bg are nil."
(shr-generic cont)) (shr-generic cont))
(defun shr-tag-span (cont) (defun shr-tag-span (cont)
(let ((title (cdr (assq :title cont)))) (shr-generic cont))
(shr-generic cont)
(when (and title
shr-start)
(put-text-property shr-start (point) 'help-echo title))))
(defun shr-tag-h1 (cont) (defun shr-tag-h1 (cont)
(shr-heading cont 'bold 'underline)) (shr-heading cont 'bold 'underline))
...@@ -1312,35 +1326,40 @@ ones, in case fg and bg are nil." ...@@ -1312,35 +1326,40 @@ ones, in case fg and bg are nil."
(nreverse result))) (nreverse result)))
(defun shr-insert-table (table widths) (defun shr-insert-table (table widths)
(shr-insert-table-ruler widths) (let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet))
(dolist (row table) "collapse"))
(let ((start (point)) (shr-table-vertical-line (if collapse "" shr-table-vertical-line)))
(height (let ((max 0)) (unless collapse
(dolist (column row) (shr-insert-table-ruler widths))
(setq max (max max (cadr column)))) (dolist (row table)
max))) (let ((start (point))
(dotimes (i height) (height (let ((max 0))
(shr-indent) (dolist (column row)
(insert shr-table-vertical-line "\n")) (setq max (max max (cadr column))))
(dolist (column row) max)))
(goto-char start) (dotimes (i height)
(let ((lines (nth 2 column))) (shr-indent)
(dolist (line lines) (insert shr-table-vertical-line "\n"))
(end-of-line) (dolist (column row)
(insert line shr-table-vertical-line) (goto-char start)
(forward-line 1)) (let ((lines (nth 2 column)))
;; Add blank lines at padding at the bottom of the TD, (dolist (line lines)
;; possibly. (end-of-line)
(dotimes (i (- height (length lines))) (insert line shr-table-vertical-line)
(end-of-line) (forward-line 1))
(let ((start (point))) ;; Add blank lines at padding at the bottom of the TD,
(insert (make-string (string-width (car lines)) ? ) ;; possibly.
shr-table-vertical-line) (dotimes (i (- height (length lines)))
(when (nth 4 column) (end-of-line)
(shr-add-font start (1- (point)) (let ((start (point)))
(list :background (nth 4 column))))) (insert (make-string (string-width (car lines)) ? )
(forward-line 1))))) shr-table-vertical-line)
(shr-insert-table-ruler widths))) (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) (defun shr-insert-table-ruler (widths)
(when (and (bolp) (when (and (bolp)
...@@ -1393,7 +1412,8 @@ ones, in case fg and bg are nil." ...@@ -1393,7 +1412,8 @@ ones, in case fg and bg are nil."
data))) data)))
(defun shr-make-table-1 (cont widths &optional fill) (defun shr-make-table-1 (cont widths &optional fill)
(let ((trs nil)) (let ((trs nil)
(shr-inhibit-decoration (not fill)))
(dolist (row cont) (dolist (row cont)
(when (eq (car row) 'tr) (when (eq (car row) 'tr)
(let ((tds nil) (let ((tds nil)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment