From c74cb3449a0c0e54f79ecec93886a0737326e033 Mon Sep 17 00:00:00 2001
From: Gnus developers <ding@gnus.org.noreply>
Date: Sun, 16 Jun 2013 22:20:55 +0000
Subject: [PATCH] 2013-06-16 Lars Magne Ingebrigtsen <larsi@gnus.org> * eww.el
 (eww-display-html): Default to using the entire window width. * shr.el
 (shr-make-table): Cache the table rendering at the table level, and not the
 <td> level. This is a bit faster. * eww.el (eww-render): Go to the correct ID
 when given URLs ending with #id. * shr.el (shr-tag-li): Don't require a new
 paragraph, since other browsers don't. (shr-expand-url): Respect #anchor
 links. (shr-parse-base): Chop off the anchor before using. (shr-descend):
 Respect display: none. (shr-descend): Allow marking elements that have
 certain IDs. * eww.el (eww-tag-textarea): Use `text' instead of
 `editable-field'. * shr.el (shr-expand-url): Don't bug out on zero-length
 links. * eww.el (eww-tag-textarea): Support <textarea>.
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

2013-06-16 Rüdiger Sonderfeld <ruediger@c-plusplus.de>
* shr.el (shr-dom-to-xml): Fixed function call.
* eww.el (eww): New group.
(eww-header-line-format): New custom variable.
(eww-current-title): New variable.
(eww-display-html): Update header and handle title tag.
(eww-update-header-line-format): New function.
(eww-tag-title): New function.
* shr.el (shr-dom-to-xml): (shr-dom-to-xml): New function.
(shr-tag-svg): Add support for the SVG tag.
(shr-bullet): New custom variable.
(shr-tag-li): Support custom bullet in unordered lists.
2013-06-16 Lars Magne Ingebrigtsen <larsi@gnus.org>
* shr.el (shr-expand-url): Respect // URLs.
* eww.el (eww-tag-body): Override the shr body rendering so that we can
put a background colour onto the entire buffer.
(eww-render): When being redirected, use the redirect URL as the new
base URL.
* shr.el (shr-parse-base): Fix parsing error.
* eww.el (eww-submit): Pass the base in to `shr-expand-url'.
* shr.el (shr-parse-base): New function.
(shr-expand-url): Use it to expand relative URLs reliably.
---
 lisp/gnus/ChangeLog |  55 ++++++++++++++
 lisp/gnus/eww.el    | 121 +++++++++++++++++++++++++-----
 lisp/gnus/shr.el    | 177 ++++++++++++++++++++++++++++----------------
 3 files changed, 270 insertions(+), 83 deletions(-)

diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 33ae989d15a..58b5ae1a56a 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,58 @@
+2013-06-16  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+	* eww.el (eww-display-html): Default to using the entire window width.
+
+	* shr.el (shr-make-table): Cache the table rendering at the table
+	level, and not the <td> level.  This is a bit faster.
+
+	* eww.el (eww-render): Go to the correct ID when given URLs ending with
+	#id.
+
+	* shr.el (shr-tag-li): Don't require a new paragraph, since other
+	browsers don't.
+	(shr-expand-url): Respect #anchor links.
+	(shr-parse-base): Chop off the anchor before using.
+	(shr-descend): Respect display: none.
+	(shr-descend): Allow marking elements that have certain IDs.
+
+	* eww.el (eww-tag-textarea): Use `text' instead of `editable-field'.
+
+	* shr.el (shr-expand-url): Don't bug out on zero-length links.
+
+	* eww.el (eww-tag-textarea): Support <textarea>.
+
+2013-06-16  Rüdiger Sonderfeld  <ruediger@c-plusplus.de>
+
+	* shr.el (shr-dom-to-xml): Fixed function call.
+
+	* eww.el (eww): New group.
+	(eww-header-line-format): New custom variable.
+	(eww-current-title): New variable.
+	(eww-display-html): Update header and handle title tag.
+	(eww-update-header-line-format): New function.
+	(eww-tag-title): New function.
+
+	* shr.el (shr-dom-to-xml): (shr-dom-to-xml): New function.
+	(shr-tag-svg): Add support for the SVG tag.
+	(shr-bullet): New custom variable.
+	(shr-tag-li): Support custom bullet in unordered lists.
+
+2013-06-16  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+	* shr.el (shr-expand-url): Respect // URLs.
+
+	* eww.el (eww-tag-body): Override the shr body rendering so that we can
+	put a background colour onto the entire buffer.
+	(eww-render): When being redirected, use the redirect URL as the new
+	base URL.
+
+	* shr.el (shr-parse-base): Fix parsing error.
+
+	* eww.el (eww-submit): Pass the base in to `shr-expand-url'.
+
+	* shr.el (shr-parse-base): New function.
+	(shr-expand-url): Use it to expand relative URLs reliably.
+
 2013-06-15  Teodor Zlatanov  <tzz@lifelogs.com>
 
 	* auth-source.el (auth-source-search-collection): Fix docstring.
diff --git a/lisp/gnus/eww.el b/lisp/gnus/eww.el
index 270c3ee3ed2..b34ec7655cc 100644
--- a/lisp/gnus/eww.el
+++ b/lisp/gnus/eww.el
@@ -29,7 +29,22 @@
 (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)
+
 (defvar eww-current-url nil)
+(defvar eww-current-title ""
+  "Title of current page.")
 (defvar eww-history nil)
 
 ;;;###autoload
@@ -53,7 +68,13 @@
 	     (match-string 1)))))
 
 (defun eww-render (status url &optional point)
+  (let ((redirect (plist-get status :redirect)))
+    (when redirect
+      (setq url redirect)))
   (let* ((headers (eww-parse-headers))
+	 (shr-target-id
+	  (and (string-match "#\\(.*\\)" url)
+	       (match-string 1 url)))
 	 (content-type
 	  (mail-header-parse-content-type
 	   (or (cdr (assoc "content-type" headers))
@@ -74,8 +95,14 @@
 	    (eww-display-image))
 	   (t
 	    (eww-display-raw charset)))
-	  (when point
-	    (goto-char point)))
+	  (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 ()
@@ -101,15 +128,56 @@
 	  (libxml-parse-html-region (point) (point-max)))))
     (eww-setup-buffer)
     (setq eww-current-url url)
+    (eww-update-header-line-format)
     (let ((inhibit-read-only t)
+	  (shr-width nil)
 	  (shr-external-rendering-functions
-	   '((form . eww-tag-form)
+	   '((title . eww-tag-title)
+	     (form . eww-tag-form)
 	     (input . eww-tag-input)
+	     (textarea . eww-tag-textarea)
+	     (body . eww-tag-body)
 	     (select . eww-tag-select))))
       (shr-insert-document document)
       (eww-convert-widgets))
     (goto-char (point-min))))
 
+(defun eww-update-header-line-format ()
+  (if eww-header-line-format
+      (setq header-line-format (format-spec eww-header-line-format
+                                            `((?u . ,eww-current-url)
+                                              (?t . ,eww-current-title))))
+    (setq header-line-format nil)))
+
+(defun eww-tag-title (cont)
+  (setq eww-current-title "")
+  (dolist (sub cont)
+    (when (eq (car sub) 'text)
+      (setq eww-current-title (concat eww-current-title (cdr sub)))))
+  (eww-update-header-line-format))
+
+(defun eww-tag-body (cont)
+  (let* ((start (point))
+	 (fgcolor (cdr (or (assq :fgcolor cont)
+                           (assq :text cont))))
+	 (bgcolor (cdr (assq :bgcolor cont)))
+	 (shr-stylesheet (list (cons 'color fgcolor)
+			       (cons 'background-color bgcolor))))
+    (shr-generic cont)
+    (eww-colorize-region start (point) fgcolor bgcolor)))
+
+(defun eww-colorize-region (start end fg &optional bg)
+  (when (or fg bg)
+    (let ((new-colors (shr-color-check fg bg)))
+      (when new-colors
+	(when fg
+	  (eww-put-color start end :foreground (cadr new-colors)))
+	(when bg
+	  (eww-put-color start end :background (car new-colors)))))))
+
+(defun eww-put-color (start end type color)
+  (shr-put-color-1 start end type color))
+
 (defun eww-display-raw (charset)
   (let ((data (buffer-substring (point) (point-max))))
     (eww-setup-buffer)
@@ -240,6 +308,21 @@
       (apply 'widget-create widget)
       (put-text-property start (point) 'eww-widget widget))))
 
+(defun eww-tag-textarea (cont)
+  (let* ((start (point))
+	 (widget
+	  (list 'text
+		:size (string-to-number
+		       (or (cdr (assq :cols cont))
+			   "40"))
+		:value (or (cdr (assq 'text cont)) "")
+		:action 'eww-submit
+		:name (cdr (assq :name cont))
+		:eww-form eww-form)))
+    (nconc eww-form (list widget))
+    (apply 'widget-create widget)
+    (put-text-property start (point) 'eww-widget widget)))
+
 (defun eww-tag-select (cont)
   (shr-ensure-paragraph)
   (let ((menu (list 'menu-choice
@@ -330,22 +413,22 @@
 			  (plist-get (cdr elem) :value))
 		    values)
 	      (setq rest nil))))))
-    (debug values)
-    (let ((shr-base eww-current-url))
-      (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-browse-url
-	 (concat
-	  (if (cdr (assq :action form))
-	      (shr-expand-url (cdr (assq :action form)))
-	    eww-current-url)
-	  "?"
-	  (mm-url-encode-www-form-urlencoded 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))))))
 
 (defun eww-convert-widgets ()
   (let ((start (point-min))
diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el
index c93357efd25..339b9698922 100644
--- a/lisp/gnus/shr.el
+++ b/lisp/gnus/shr.el
@@ -83,6 +83,14 @@ used."
 		 (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
@@ -115,6 +123,7 @@ cid: URL as the argument.")
 (defvar shr-base nil)
 (defvar shr-ignore-cache nil)
 (defvar shr-external-rendering-functions nil)
+(defvar shr-target-id nil)
 
 (defvar shr-map
   (let ((map (make-sparse-keymap)))
@@ -303,18 +312,24 @@ size, and full-buffer size."
 	(shr-stylesheet shr-stylesheet)
 	(start (point)))
     (when style
-      (if (string-match "color" style)
+      (if (string-match "color\\|display" style)
 	  (setq shr-stylesheet (nconc (shr-parse-style style)
 				      shr-stylesheet))
 	(setq style nil)))
-    (if (fboundp function)
-	(funcall function (cdr dom))
-      (shr-generic (cdr dom)))
-    ;; 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))))))
+    ;; 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)
@@ -484,31 +499,51 @@ size, and full-buffer size."
 	 (forward-char 1))))
     (not failed)))
 
-(defun shr-expand-url (url)
-  (if (or (not url)
-	  (string-match "\\`[a-z]*:" url)
-	  (not shr-base))
-      ;; Absolute URL.
-      url
-    (let ((base shr-base))
-      ;; Chop off query string.
-      (when (string-match "\\`\\([^?]+\\)[?]" base)
-	(setq base (match-string 1 base)))
-      ;; Chop off the bit after the last slash.
-      (when (string-match "\\`\\(.*\\)[/][^/]+" base)
-	(setq base (match-string 1 base)))
-      (cond
-       ((and (string-match "\\`//" url)
-	     (string-match "\\`[a-z]*:" base))
-	(concat (match-string 0 base) url))
-       ((and (not (string-match "/\\'" base))
-	     (not (string-match "\\`/" url)))
-	(concat base "/" url))
-       ((and (string-match "\\`/" url)
-	     (string-match "\\(\\`[^:]*://[^/]+\\)/" base))
-	(concat (match-string 1 base) url))
-       (t
-	(concat base url))))))
+(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))
@@ -894,8 +929,31 @@ ones, in case fg and bg are nil."
 (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)))
@@ -965,7 +1023,7 @@ ones, in case fg and bg are nil."
       plist)))
 
 (defun shr-tag-base (cont)
-  (setq shr-base (cdr (assq :href cont)))
+  (setq shr-base (shr-parse-base (cdr (assq :href cont))))
   (shr-generic cont))
 
 (defun shr-tag-a (cont)
@@ -1087,14 +1145,14 @@ ones, in case fg and bg are nil."
   (shr-ensure-paragraph))
 
 (defun shr-tag-li (cont)
-  (shr-ensure-paragraph)
+  (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)))
@@ -1352,6 +1410,13 @@ ones, in case fg and bg are nil."
     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))
     (dolist (row cont)
       (when (eq (car row) 'tr)
@@ -1385,32 +1450,16 @@ ones, in case fg and bg are nil."
 	(setq style (nconc (list (cons 'color fgcolor)) style)))
       (when style
 	(setq shr-stylesheet (append style shr-stylesheet)))
-      (let ((cache (cdr (assoc (cons width cont) shr-content-cache))))
-	(if cache
-	    (progn
-	      (insert (car cache))
-	      (let ((end (length (car cache))))
-		(dolist (overlay (cadr cache))
-		  (let ((new-overlay
-			 (shr-make-overlay (1+ (- end (nth 0 overlay)))
-					   (1+ (- end (nth 1 overlay)))))
-			(properties (nth 2 overlay)))
-		    (while properties
-		      (overlay-put new-overlay
-				   (pop properties) (pop properties)))))))
-	  (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)))
-	  (push (list (cons width cont) (buffer-string)
-		      (shr-overlays-in-region (point-min) (point-max)))
-		shr-content-cache)))
+      (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))
-- 
2.39.2