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.

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))