From: Lars Magne Ingebrigtsen Date: Mon, 10 Jun 2013 14:11:01 +0000 (+0000) Subject: lisp/gnus/eww.el: Add form support; Make form submission work; Support POST X-Git-Tag: emacs-24.3.90~173^2^2~42^2~45^2~387^2~2026^2~17 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=2644071e8ef9de418b58c4d84ef7b13f1ea5d1fe;p=emacs.git lisp/gnus/eww.el: Add form support; Make form submission work; Support POST --- diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index ee540465a3c..69137ff7358 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,6 +1,13 @@ 2013-06-10 Lars Magne Ingebrigtsen + * eww.el (eww-submit): Make form submission work. + + * shr.el (shr-descend): Allow other packages to override (or provide) + rendering of elements. + (shr-expand-url): Strip query strings from URLs before expanding them. + * eww.el: Don't require cl-lib. + (eww-tag-form): Start form support. * eww.el: Start writing a new, tiny web browser. (eww-previous-url): New command. diff --git a/lisp/gnus/eww.el b/lisp/gnus/eww.el index c4a664022ac..63ad6fd4f8a 100644 --- a/lisp/gnus/eww.el +++ b/lisp/gnus/eww.el @@ -27,6 +27,7 @@ (eval-when-compile (require 'cl)) (require 'shr) (require 'url) +(require 'mm-url) (defvar eww-current-url nil) (defvar eww-history nil) @@ -82,8 +83,13 @@ (libxml-parse-html-region (point) (point-max))))) (eww-setup-buffer) (setq eww-current-url url) - (let ((inhibit-read-only t)) - (shr-insert-document document)) + (let ((inhibit-read-only t) + (shr-external-rendering-functions + '((form . eww-tag-form) + (input . eww-tag-input) + (submit . eww-tag-submit)))) + (shr-insert-document document) + (eww-convert-widgets)) (goto-char (point-min)))) (defun eww-display-raw (charset) @@ -102,6 +108,8 @@ (defun eww-setup-buffer () (pop-to-buffer (get-buffer-create "*eww*")) + (remove-overlays) + (setq widget-field-list nil) (let ((inhibit-read-only t)) (erase-buffer)) (eww-mode)) @@ -128,7 +136,7 @@ mode-name "eww") (set (make-local-variable 'eww-current-url) 'author) (set (make-local-variable 'browse-url-browser-function) 'eww-browse-url) - (setq buffer-read-only t) + ;;(setq buffer-read-only t) (use-local-map eww-mode-map)) (defun eww-browse-url (url &optional new-window) @@ -150,6 +158,70 @@ (let ((prev (pop eww-history))) (url-retrieve (car prev) 'eww-render (list (car prev) (cadr prev))))) +;; Form support. + +(defvar eww-form nil) + +(defun eww-tag-form (cont) + (let ((eww-form + (list (assq :method cont) + (assq :action cont))) + (start (point))) + (shr-ensure-paragraph) + (shr-generic cont) + (shr-ensure-paragraph) + (put-text-property start (1+ start) + '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) + (put-text-property start (point) 'eww-widget widget))) + +(defun eww-submit (widget dummy) + (let ((form (getf (cdr widget) :eww-form)) + 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))) + (when name + (push (cons name (widget-value field)) + values)))))) + (let ((shr-base eww-current-url)) + (if (and (stringp (getf form :method)) + (equal (downcase (getf 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 + (concat + (getf form :action) + "?" + (mm-url-encode-www-form-urlencoded values)))))))) + +(defun eww-convert-widgets () + (let ((start (point-min)) + widget) + (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))) + (provide 'eww) ;;; eww.el ends here diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el index 6e0aa26e376..bf9f5a4e3d4 100644 --- a/lisp/gnus/shr.el +++ b/lisp/gnus/shr.el @@ -114,6 +114,7 @@ cid: URL as the argument.") (defvar shr-stylesheet nil) (defvar shr-base nil) (defvar shr-ignore-cache nil) +(defvar shr-external-rendering-functions nil) (defvar shr-map (let ((map (make-sparse-keymap))) @@ -291,7 +292,12 @@ size, and full-buffer size." (nreverse result))) (defun shr-descend (dom) - (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray)) + (let ((function + (or + ;; Allow other packages to override (or provide) rendering + ;; of elements. + (cdr (assq (car dom) shr-external-rendering-functions)) + (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))) (style (cdr (assq :style (cdr dom)))) (shr-stylesheet shr-stylesheet) (start (point))) @@ -478,20 +484,23 @@ size, and full-buffer size." (not failed))) (defun shr-expand-url (url) - (cond - ;; Absolute URL. - ((or (not url) - (string-match "\\`[a-z]*:" url) - (not shr-base)) - url) - ((and (string-match "\\`//" url) - (string-match "\\`[a-z]*:" shr-base)) - (concat (match-string 0 shr-base) url)) - ((and (not (string-match "/\\'" shr-base)) - (not (string-match "\\`/" url))) - (concat shr-base "/" url)) - (t - (concat shr-base url)))) + (if (or (not url) + (string-match "\\`[a-z]*:" url) + (not shr-base)) + ;; Absolute URL. + url + (let ((base shr-base)) + (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)) + (t + (concat base url)))))) (defun shr-ensure-newline () (unless (zerop (current-column))