[Emacs-diffs] trunk r112916: lisp/gnus/eww.el (eww-tag-input): Implement submit buttons

[Katsumi Yamaoka]

------------------------------------------------------------
revno: 112916
revision-id: address@hidden
parent: address@hidden
author: Lars Magne Ingebrigtsen <address@hidden>
committer: Katsumi Yamaoka <address@hidden>
branch nick: trunk
timestamp: Mon 2013-06-10 22:12:47 +0000
message:
  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

=== modified file 'lisp/gnus/ChangeLog'
--- a/lisp/gnus/ChangeLog       2013-06-10 14:11:01 +0000
+++ b/lisp/gnus/ChangeLog       2013-06-10 22:12:47 +0000
@@ -1,6 +1,18 @@
 2013-06-10  Lars Magne Ingebrigtsen  <address@hidden>
 
+       * 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.

=== modified file 'lisp/gnus/eww.el'
--- a/lisp/gnus/eww.el  2013-06-10 14:11:01 +0000
+++ b/lisp/gnus/eww.el  2013-06-10 22:12:47 +0000
@@ -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)
 

=== modified file 'lisp/gnus/shr.el'
--- a/lisp/gnus/shr.el  2013-06-10 14:11:01 +0000
+++ b/lisp/gnus/shr.el  2013-06-10 22:12:47 +0000
@@ -115,6 +115,7 @@
 (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 @@
       ;; 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 @@
        ((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 @@
             (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.