lisp/gnus/eww.el (eww-tag-input): Implement submit buttons

(eww-click-radio): Implement radio and checkboxes
(eww-submit): Handle hidden elements
(eww-submit): Get submit button logic right
lisp/gnus/shr.el (shr-expand-url): Expand URLs that start with a slash correctly

3 files changed, 135 insertions, 29 deletions

diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 69137ff7358..f4d45e9fd0b 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,6 +1,18 @@
 2013-06-10  Lars Magne Ingebrigtsen  <larsi@gnus.org>
 
+        * shr.el (shr-expand-url): Expand URLs that start with a slash
+        correctly.
+
+        * eww.el (eww-submit): Get submit button logic right.
+
+        * shr.el (shr-final-table-render): New variable to signal when we're
+        doing the final table rendering so that we can collect more data at
+        that point.
+
         * eww.el (eww-submit): Make form submission work.
+        (eww-tag-input): Implement submit buttons.
+        (eww-click-radio): Implement radio and checkboxes.
+        (eww-submit): Handle hidden elements.
 
         * shr.el (shr-descend): Allow other packages to override (or provide)
         rendering of elements.
diff --git a/lisp/gnus/eww.el b/lisp/gnus/eww.el
index 63ad6fd4f8a..1a072244fb4 100644
--- a/lisp/gnus/eww.el
+++ b/lisp/gnus/eww.el
@@ -118,6 +118,7 @@
   (let ((map (make-sparse-keymap)))
     (suppress-keymap map)
     (define-key map "q" 'eww-quit)
+    (define-key map "g" 'eww-reload)
     (define-key map [tab] 'widget-forward)
     (define-key map [backtab] 'widget-backward)
     (define-key map [delete] 'scroll-down-command)
@@ -158,6 +159,12 @@
   (let ((prev (pop eww-history)))
     (url-retrieve (car prev) 'eww-render (list (car prev) (cadr prev)))))
 
+(defun eww-reload ()
+  "Reload the current page."
+  (interactive)
+  (url-retrieve eww-current-url 'eww-render
+                (list eww-current-url (point))))
+
 ;; Form support.
 
 (defvar eww-form nil)
@@ -174,40 +181,112 @@
                        'eww-form eww-form)))
 
 (defun eww-tag-input (cont)
-  (let ((start (point))
-        (widget (list
-                 'editable-field
-                 :size (string-to-number
-                        (or (cdr (assq :size cont))
-                            "40"))
-                 :value (or (cdr (assq :value cont)) "")
-                 :action 'eww-submit
-                 :name (cdr (assq :name cont))
-                 :eww-form eww-form)))
-    (apply 'widget-create widget)
-    (shr-generic cont)
+  (let* ((start (point))
+         (type (downcase (or (cdr (assq :type cont))
+                             "text")))
+         (widget
+          (cond
+           ((equal type "submit")
+            (list
+             'push-button
+             :notify 'eww-submit
+             :name (cdr (assq :name cont))
+             :eww-form eww-form
+             (or (cdr (assq :value cont)) "Submit")))
+           ((or (equal type "radio")
+                (equal type "checkbox"))
+            (list 'checkbox
+                  :notify 'eww-click-radio
+                  :name (cdr (assq :name cont))
+                  :checkbox-value (cdr (assq :value cont))
+                  :eww-form eww-form
+                  (cdr (assq :checked cont))))
+           ((equal type "hidden")
+            (list 'hidden
+                  :name (cdr (assq :name cont))
+                  :value (cdr (assq :value cont))))
+           (t
+            (list
+             'editable-field
+             :size (string-to-number
+                    (or (cdr (assq :size cont))
+                        "40"))
+             :value (or (cdr (assq :value cont)) "")
+             :action 'eww-submit
+             :name (cdr (assq :name cont))
+             :eww-form eww-form)))))
+    (if (eq (car widget) 'hidden)
+        (when shr-final-table-render
+          (nconc eww-form (list widget)))
+      (apply 'widget-create widget))
     (put-text-property start (point) 'eww-widget widget)))
 
-(defun eww-submit (widget dummy)
-  (let ((form (getf (cdr widget) :eww-form))
+(defun eww-click-radio (widget &rest ignore)
+  (let ((form (plist-get (cdr widget) :eww-form))
+        (name (plist-get (cdr widget) :name)))
+    (if (widget-value widget)
+        ;; Switch all the other radio buttons off.
+        (dolist (overlay (overlays-in (point-min) (point-max)))
+          (let ((field (plist-get (overlay-properties overlay) 'button)))
+            (when (and (eq (plist-get (cdr field) :eww-form) form)
+                       (equal name (plist-get (cdr field) :name)))
+              (unless (eq field widget)
+                (widget-value-set field nil)))))
+      (widget-value-set widget t))
+    (eww-fix-widget-keymap)))
+
+(defun eww-submit (widget &rest ignore)
+  (let ((form (plist-get (cdr widget) :eww-form))
+        (first-button t)
         values)
-    (dolist (overlay (overlays-in (point-min) (point-max)))
-      (let ((field (getf (overlay-properties overlay) 'field)))
-        (when (eq (getf (cdr field) :eww-form) form)
-          (let ((name (getf (cdr field) :name)))
+    (dolist (overlay (sort (overlays-in (point-min) (point-max))
+                           (lambda (o1 o2)
+                             (< (overlay-start o1) (overlay-start o2)))))
+      (let ((field (or (plist-get (overlay-properties overlay) 'field)
+                       (plist-get (overlay-properties overlay) 'button)
+                       (plist-get (overlay-properties overlay) 'eww-hidden))))
+        (when (eq (plist-get (cdr field) :eww-form) form)
+          (let ((name (plist-get (cdr field) :name)))
             (when name
-              (push (cons name (widget-value field))
-                    values))))))
+              (cond
+               ((eq (car field) 'checkbox)
+                (when (widget-value field)
+                  (push (cons name (plist-get (cdr field) :checkbox-value))
+                        values)))
+               ((eq (car field) 'eww-hidden)
+                (push (cons name (plist-get (cdr field) :value))
+                      values))
+               ((eq (car field) 'push-button)
+                ;; We want the values from buttons if we hit a button,
+                ;; or we're submitting something and this is the first
+                ;; button displayed.
+                (when (or (and (eq (car widget) 'push-button)
+                               (eq widget field))
+                          (and (not (eq (car widget) 'push-button))
+                               (eq (car field) 'push-button)
+                               first-button))
+                  (setq first-button nil)
+                  (push (cons name (widget-value field))
+                        values)))
+               (t
+                (push (cons name (widget-value field))
+                      values))))))))
+    (dolist (elem form)
+      (when (and (consp elem)
+                 (eq (car elem) 'hidden))
+        (push (cons (plist-get (cdr elem) :name)
+                    (plist-get (cdr elem) :value))
+              values)))
     (let ((shr-base eww-current-url))
-      (if (and (stringp (getf form :method))
-               (equal (downcase (getf form :method)) "post"))
+      (if (and (stringp (plist-get form :method))
+               (equal (downcase (plist-get form :method)) "post"))
           (let ((url-request-method "POST")
                 (url-request-data (mm-url-encode-www-form-urlencoded values)))
-            (eww-browse-url (shr-expand-url (getf form :action))))
+            (eww-browse-url (shr-expand-url (plist-get form :action))))
         (eww-browse-url
          (shr-expand-url
           (concat
-           (getf form :action)
+           (cdr (assq :action form))
            "?"
            (mm-url-encode-www-form-urlencoded values))))))))
 
@@ -217,10 +296,19 @@
     (while (setq start (next-single-property-change start 'eww-widget))
       (setq widget (get-text-property start 'eww-widget))
       (goto-char start)
-      (delete-region start (next-single-property-change start 'eww-widget))
-      (apply 'widget-create widget)
-      (put-text-property start (point) 'not-read-only t))
-    (widget-setup)))
+      (let ((end (next-single-property-change start 'eww-widget)))
+        (dolist (overlay (overlays-in start end))
+          (when (plist-get (overlay-properties overlay) 'button)
+            (delete-overlay overlay)))
+        (delete-region start end))
+      (apply 'widget-create widget))
+    (widget-setup)
+    (eww-fix-widget-keymap)))
+
+(defun eww-fix-widget-keymap ()
+  (dolist (overlay (overlays-in (point-min) (point-max)))
+    (when (plist-get (overlay-properties overlay) 'button)
+      (overlay-put overlay 'local-map widget-keymap))))
 
 (provide 'eww)
 
diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el
index bf9f5a4e3d4..d9e267e5288 100644
--- a/lisp/gnus/shr.el
+++ b/lisp/gnus/shr.el
@@ -115,6 +115,7 @@ cid: URL as the argument.")
 (defvar shr-base nil)
 (defvar shr-ignore-cache nil)
 (defvar shr-external-rendering-functions nil)
+(defvar shr-final-table-render nil)
 
 (defvar shr-map
   (let ((map (make-sparse-keymap)))
@@ -490,6 +491,7 @@ size, and full-buffer size."
       ;; Absolute URL.
       url
     (let ((base shr-base))
+      ;; Chop off query string.
       (when (string-match "^\\([^?]+\\)[?]" base)
         (setq base (match-string 1 base)))
       (cond
@@ -499,6 +501,9 @@ size, and full-buffer size."
        ((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))))))
 
@@ -1177,7 +1182,8 @@ ones, in case fg and bg are nil."
              (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))
+    (let ((shr-final-table-render t))
+      (shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths)))
   ;; 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.