lisp/gnus/eww.el

   1 ;;; eww.el --- Emacs Web Wowser
   2
   3 ;; Copyright (C) 2013 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: html
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (eval-when-compile (require 'cl))
  28 (require 'shr)
  29 (require 'url)
  30 (require 'mm-url)
  31
  32 (defvar eww-current-url nil)
  33 (defvar eww-history nil)
  34
  35 ;;;###autoload
  36 (defun eww (url)
  37   "Fetch URL and render the page."
  38   (interactive "sUrl: ")
  39   (unless (string-match-p "\\`[a-zA-Z][-a-zA-Z0-9+.]*://" url)
  40     (setq url (concat "http://" url)))
  41   (url-retrieve url 'eww-render (list url)))
  42
  43 (defun eww-detect-charset (html-p)
  44   (let ((case-fold-search t)
  45         (pt (point)))
  46     (or (and html-p
  47              (re-search-forward
  48               "<meta[\t\n\r ]+[^>]*charset=\\([^\t\n\r \"/>]+\\)" nil t)
  49              (goto-char pt)
  50              (match-string 1))
  51         (and (looking-at
  52               "[\t\n\r ]*<\\?xml[\t\n\r ]+[^>]*encoding=\"\\([^\"]+\\)")
  53              (match-string 1)))))
  54
  55 (defun eww-render (status url &optional point)
  56   (let* ((headers (eww-parse-headers))
  57          (content-type
  58           (mail-header-parse-content-type
  59            (or (cdr (assoc "content-type" headers))
  60                "text/plain")))
  61          (charset (intern
  62                    (downcase
  63                     (or (cdr (assq 'charset (cdr content-type)))
  64                         (eww-detect-charset (equal (car content-type)
  65                                                    "text/html"))
  66                         "utf8"))))
  67          (data-buffer (current-buffer)))
  68     (unwind-protect
  69         (progn
  70           (cond
  71            ((equal (car content-type) "text/html")
  72             (eww-display-html charset url))
  73            ((string-match "^image/" (car content-type))
  74             (eww-display-image))
  75            (t
  76             (eww-display-raw charset)))
  77           (when point
  78             (goto-char point)))
  79       (kill-buffer data-buffer))))
  80
  81 (defun eww-parse-headers ()
  82   (let ((headers nil))
  83     (goto-char (point-min))
  84     (while (and (not (eobp))
  85                 (not (eolp)))
  86       (when (looking-at "\\([^:]+\\): *\\(.*\\)")
  87         (push (cons (downcase (match-string 1))
  88                     (match-string 2))
  89               headers))
  90       (forward-line 1))
  91     (unless (eobp)
  92       (forward-line 1))
  93     headers))
  94
  95 (defun eww-display-html (charset url)
  96   (unless (eq charset 'utf8)
  97     (decode-coding-region (point) (point-max) charset))
  98   (let ((document
  99          (list
 100           'base (list (cons 'href url))
 101           (libxml-parse-html-region (point) (point-max)))))
 102     (eww-setup-buffer)
 103     (setq eww-current-url url)
 104     (let ((inhibit-read-only t)
 105           (shr-external-rendering-functions
 106            '((form . eww-tag-form)
 107              (input . eww-tag-input)
 108              (select . eww-tag-select))))
 109       (shr-insert-document document)
 110       (eww-convert-widgets))
 111     (goto-char (point-min))))
 112
 113 (defun eww-display-raw (charset)
 114   (let ((data (buffer-substring (point) (point-max))))
 115     (eww-setup-buffer)
 116     (let ((inhibit-read-only t))
 117       (insert data))
 118     (goto-char (point-min))))
 119
 120 (defun eww-display-image ()
 121   (let ((data (buffer-substring (point) (point-max))))
 122     (eww-setup-buffer)
 123     (let ((inhibit-read-only t))
 124       (shr-put-image data nil))
 125     (goto-char (point-min))))
 126
 127 (defun eww-setup-buffer ()
 128   (pop-to-buffer (get-buffer-create "*eww*"))
 129   (remove-overlays)
 130   (setq widget-field-list nil)
 131   (let ((inhibit-read-only t))
 132     (erase-buffer))
 133   (eww-mode))
 134
 135 (defvar eww-mode-map
 136   (let ((map (make-sparse-keymap)))
 137     (suppress-keymap map)
 138     (define-key map "q" 'eww-quit)
 139     (define-key map "g" 'eww-reload)
 140     (define-key map [tab] 'widget-forward)
 141     (define-key map [backtab] 'widget-backward)
 142     (define-key map [delete] 'scroll-down-command)
 143     (define-key map "\177" 'scroll-down-command)
 144     (define-key map " " 'scroll-up-command)
 145     (define-key map "p" 'eww-previous-url)
 146     ;;(define-key map "n" 'eww-next-url)
 147     map))
 148
 149 (define-derived-mode eww-mode nil "eww"
 150   "Mode for browsing the web.
 151
 152 \\{eww-mode-map}"
 153   (set (make-local-variable 'eww-current-url) 'author)
 154   (set (make-local-variable 'browse-url-browser-function) 'eww-browse-url))
 155
 156 (defun eww-browse-url (url &optional new-window)
 157   (let ((url-request-extra-headers
 158          (append '(("User-Agent" . "eww/1.0"))
 159                  url-request-extra-headers)))
 160     (push (list eww-current-url (point))
 161           eww-history)
 162     (eww url)))
 163
 164 (defun eww-quit ()
 165   "Exit the Emacs Web Wowser."
 166   (interactive)
 167   (setq eww-history nil)
 168   (kill-buffer (current-buffer)))
 169
 170 (defun eww-previous-url ()
 171   "Go to the previously displayed page."
 172   (interactive)
 173   (when (zerop (length eww-history))
 174     (error "No previous page"))
 175   (let ((prev (pop eww-history)))
 176     (url-retrieve (car prev) 'eww-render (list (car prev) (cadr prev)))))
 177
 178 (defun eww-reload ()
 179   "Reload the current page."
 180   (interactive)
 181   (url-retrieve eww-current-url 'eww-render
 182                 (list eww-current-url (point))))
 183
 184 ;; Form support.
 185
 186 (defvar eww-form nil)
 187
 188 (defun eww-tag-form (cont)
 189   (let ((eww-form
 190          (list (assq :method cont)
 191                (assq :action cont)))
 192         (start (point)))
 193     (shr-ensure-paragraph)
 194     (shr-generic cont)
 195     (unless (bolp)
 196       (insert "\n"))
 197     (insert "\n")
 198     (when (> (point) start)
 199       (put-text-property start (1+ start)
 200                          'eww-form eww-form))))
 201
 202 (defun eww-tag-input (cont)
 203   (let* ((start (point))
 204          (type (downcase (or (cdr (assq :type cont))
 205                              "text")))
 206          (widget
 207           (cond
 208            ((equal type "submit")
 209             (list
 210              'push-button
 211              :notify 'eww-submit
 212              :name (cdr (assq :name cont))
 213              :eww-form eww-form
 214              (or (cdr (assq :value cont)) "Submit")))
 215            ((or (equal type "radio")
 216                 (equal type "checkbox"))
 217             (list 'checkbox
 218                   :notify 'eww-click-radio
 219                   :name (cdr (assq :name cont))
 220                   :checkbox-value (cdr (assq :value cont))
 221                   :checkbox-type type
 222                   :eww-form eww-form
 223                   (cdr (assq :checked cont))))
 224            ((equal type "hidden")
 225             (list 'hidden
 226                   :name (cdr (assq :name cont))
 227                   :value (cdr (assq :value cont))))
 228            (t
 229             (list
 230              'editable-field
 231              :size (string-to-number
 232                     (or (cdr (assq :size cont))
 233                         "40"))
 234              :value (or (cdr (assq :value cont)) "")
 235              :secret (and (equal type "password") ?*)
 236              :action 'eww-submit
 237              :name (cdr (assq :name cont))
 238              :eww-form eww-form)))))
 239     (if (eq (car widget) 'hidden)
 240         (nconc eww-form (list widget))
 241       (apply 'widget-create widget)
 242       (put-text-property start (point) 'eww-widget widget))))
 243
 244 (defun eww-tag-select (cont)
 245   (shr-ensure-paragraph)
 246   (let ((menu (list 'menu-choice
 247                     :name (cdr (assq :name cont))
 248                     :eww-form eww-form))
 249         (options nil)
 250         (start (point)))
 251     (dolist (elem cont)
 252       (when (eq (car elem) 'option)
 253         (when (cdr (assq :selected (cdr elem)))
 254           (nconc menu (list :value
 255                             (cdr (assq :value (cdr elem))))))
 256         (push (list 'item
 257                     :value (cdr (assq :value (cdr elem)))
 258                     :tag (cdr (assq 'text (cdr elem))))
 259               options)))
 260     ;; If we have no selected values, default to the first value.
 261     (unless (plist-get (cdr menu) :value)
 262       (nconc menu (list :value (nth 2 (car options)))))
 263     (nconc menu options)
 264     (apply 'widget-create menu)
 265     (put-text-property start (point) 'eww-widget menu)
 266     (shr-ensure-paragraph)))
 267
 268 (defun eww-click-radio (widget &rest ignore)
 269   (let ((form (plist-get (cdr widget) :eww-form))
 270         (name (plist-get (cdr widget) :name)))
 271     (when (equal (plist-get (cdr widget) :type) "radio")
 272       (if (widget-value widget)
 273           ;; Switch all the other radio buttons off.
 274           (dolist (overlay (overlays-in (point-min) (point-max)))
 275             (let ((field (plist-get (overlay-properties overlay) 'button)))
 276               (when (and (eq (plist-get (cdr field) :eww-form) form)
 277                          (equal name (plist-get (cdr field) :name)))
 278                 (unless (eq field widget)
 279                   (widget-value-set field nil)))))
 280         (widget-value-set widget t)))
 281     (eww-fix-widget-keymap)))
 282
 283 (defun eww-submit (widget &rest ignore)
 284   (let ((form (plist-get (cdr widget) :eww-form))
 285         (first-button t)
 286         values)
 287     (dolist (overlay (sort (overlays-in (point-min) (point-max))
 288                            (lambda (o1 o2)
 289                              (< (overlay-start o1) (overlay-start o2)))))
 290       (let ((field (or (plist-get (overlay-properties overlay) 'field)
 291                        (plist-get (overlay-properties overlay) 'button)
 292                        (plist-get (overlay-properties overlay) 'eww-hidden))))
 293         (when (eq (plist-get (cdr field) :eww-form) form)
 294           (let ((name (plist-get (cdr field) :name)))
 295             (when name
 296               (cond
 297                ((eq (car field) 'checkbox)
 298                 (when (widget-value field)
 299                   (push (cons name (plist-get (cdr field) :checkbox-value))
 300                         values)))
 301                ((eq (car field) 'eww-hidden)
 302                 (push (cons name (plist-get (cdr field) :value))
 303                       values))
 304                ((eq (car field) 'push-button)
 305                 ;; We want the values from buttons if we hit a button,
 306                 ;; or we're submitting something and this is the first
 307                 ;; button displayed.
 308                 (when (or (and (eq (car widget) 'push-button)
 309                                (eq widget field))
 310                           (and (not (eq (car widget) 'push-button))
 311                                (eq (car field) 'push-button)
 312                                first-button))
 313                   (setq first-button nil)
 314                   (push (cons name (widget-value field))
 315                         values)))
 316                (t
 317                 (push (cons name (widget-value field))
 318                       values))))))))
 319     (dolist (elem form)
 320       (when (and (consp elem)
 321                  (eq (car elem) 'hidden))
 322         (push (cons (plist-get (cdr elem) :name)
 323                     (plist-get (cdr elem) :value))
 324               values)))
 325     (let ((shr-base eww-current-url))
 326       (if (and (stringp (cdr (assq :method form)))
 327                (equal (downcase (cdr (assq :method form))) "post"))
 328           (let ((url-request-method "POST")
 329                 (url-request-extra-headers
 330                  '(("Content-Type" . "application/x-www-form-urlencoded")))
 331                 (url-request-data (mm-url-encode-www-form-urlencoded values)))
 332             (eww-browse-url (shr-expand-url (cdr (assq :action form)))))
 333         (eww-browse-url
 334          (concat
 335           (if (cdr (assq :action form))
 336               (shr-expand-url (cdr (assq :action form)))
 337             eww-current-url)
 338           "?"
 339           (mm-url-encode-www-form-urlencoded values)))))))
 340
 341 (defun eww-convert-widgets ()
 342   (let ((start (point-min))
 343         widget)
 344     ;; Some widgets come from different buffers (rendered for tables),
 345     ;; so we need to nix out the list of widgets and recreate them.
 346     (setq widget-field-list nil
 347           widget-field-new nil)
 348     (while (setq start (next-single-property-change start 'eww-widget))
 349       (setq widget (get-text-property start 'eww-widget))
 350       (goto-char start)
 351       (let ((end (next-single-property-change start 'eww-widget)))
 352         (dolist (overlay (overlays-in start end))
 353           (when (or (plist-get (overlay-properties overlay) 'button)
 354                     (plist-get (overlay-properties overlay) 'field))
 355             (delete-overlay overlay)))
 356         (delete-region start end))
 357       (when (and widget
 358                  (not (eq (car widget) 'hidden)))
 359         (apply 'widget-create widget)))
 360     (widget-setup)
 361     (eww-fix-widget-keymap)))
 362
 363 (defun eww-fix-widget-keymap ()
 364   (dolist (overlay (overlays-in (point-min) (point-max)))
 365     (when (plist-get (overlay-properties overlay) 'button)
 366       (overlay-put overlay 'local-map widget-keymap))))
 367
 368 (provide 'eww)
 369
 370 ;;; eww.el ends here