eww.el 26.2 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27
;;; eww.el --- Emacs Web Wowser

;; Copyright (C) 2013 Free Software Foundation, Inc.

;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: html

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

(eval-when-compile (require 'cl))
28
(require 'format-spec)
29 30
(require 'shr)
(require 'url)
31
(require 'mm-url)
32

33 34 35 36 37 38 39 40 41 42
(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."
43 44 45 46 47 48 49
  :version "24.4"
  :group 'eww
  :type 'string)

(defcustom eww-search-prefix "https://duckduckgo.com/html/?q="
  "Prefix URL to search engine"
  :version "24.4"
50 51 52
  :group 'eww
  :type 'string)

53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69
(defface eww-form-submit
  '((((type x w32 ns) (class color))	; Like default mode line
     :box (:line-width 2 :style released-button)
     :background "#808080" :foreground "black"))
  "Face for eww buffer buttons."
  :version "24.4"
  :group 'eww)

(defface eww-form-checkbox
  '((((type x w32 ns) (class color))	; Like default mode line
     :box (:line-width 2 :style released-button)
     :background "lightgrey" :foreground "black"))
  "Face for eww buffer buttons."
  :version "24.4"
  :group 'eww)

(defface eww-form-select
70 71 72 73 74 75 76
  '((((type x w32 ns) (class color))	; Like default mode line
     :box (:line-width 2 :style released-button)
     :background "lightgrey" :foreground "black"))
  "Face for eww buffer buttons."
  :version "24.4"
  :group 'eww)

77 78 79 80 81 82 83 84
(defface eww-form-text
  '((t (:background "#505050"
		    :foreground "white"
		    :box (:line-width 1))))
  "Face for eww text inputs."
  :version "24.4"
  :group 'eww)

85
(defvar eww-current-url nil)
86 87
(defvar eww-current-title ""
  "Title of current page.")
88
(defvar eww-history nil)
89
(defvar eww-history-position 0)
90

91 92 93
(defvar eww-next-url nil)
(defvar eww-previous-url nil)
(defvar eww-up-url nil)
94 95 96
(defvar eww-home-url nil)
(defvar eww-start-url nil)
(defvar eww-contents-url nil)
97

98
;;;###autoload
99
(defun eww (url)
100 101 102 103 104 105
  "Fetch URL and render the page.
If the input doesn't look like an URL or a domain name, the
word(s) will be searched for via `eww-search-prefix'."
  (interactive "sEnter URL or keywords: ")
  (if (and (= (length (split-string url)) 1)
           (> (length (split-string url "\\.")) 1))
106 107 108 109 110 111
      (progn
        (unless (string-match-p "\\`[a-zA-Z][-a-zA-Z0-9+.]*://" url)
          (setq url (concat "http://" url)))
        ;; some site don't redirect final /
        (when (string= (url-filename (url-generic-parse-url url)) "")
          (setq url (concat url "/"))))
112
    (unless (string-match-p "\\'file:" url)
Ivan Kanis's avatar
Ivan Kanis committed
113 114
      (setq url (concat eww-search-prefix
                        (replace-regexp-in-string " " "+" url)))))
115 116
  (url-retrieve url 'eww-render (list url)))

117 118 119 120 121 122
;;;###autoload
(defun eww-open-file (file)
  "Render a file using EWW."
  (interactive "fFile: ")
  (eww (concat "file://" (expand-file-name file))))

123
(defun eww-render (status url &optional point)
124 125 126
  (let ((redirect (plist-get status :redirect)))
    (when redirect
      (setq url redirect)))
127 128 129
  (set (make-local-variable 'eww-next-url) nil)
  (set (make-local-variable 'eww-previous-url) nil)
  (set (make-local-variable 'eww-up-url) nil)
130 131 132
  (set (make-local-variable 'eww-home-url) nil)
  (set (make-local-variable 'eww-start-url) nil)
  (set (make-local-variable 'eww-contents-url) nil)
133
  (let* ((headers (eww-parse-headers))
134 135 136
	 (shr-target-id
	  (and (string-match "#\\(.*\\)" url)
	       (match-string 1 url)))
137 138 139 140 141 142 143
	 (content-type
	  (mail-header-parse-content-type
	   (or (cdr (assoc "content-type" headers))
	       "text/plain")))
	 (charset (intern
		   (downcase
		    (or (cdr (assq 'charset (cdr content-type)))
144 145
			(eww-detect-charset (equal (car content-type)
						   "text/html"))
146 147 148 149 150 151 152 153 154 155 156
			"utf8"))))
	 (data-buffer (current-buffer)))
    (unwind-protect
	(progn
	  (cond
	   ((equal (car content-type) "text/html")
	    (eww-display-html charset url))
	   ((string-match "^image/" (car content-type))
	    (eww-display-image))
	   (t
	    (eww-display-raw charset)))
157 158 159 160 161 162 163 164
	  (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)))))))
165 166 167 168
      (kill-buffer data-buffer))))

(defun eww-parse-headers ()
  (let ((headers nil))
169
    (goto-char (point-min))
170 171 172 173 174 175 176 177 178 179 180
    (while (and (not (eobp))
		(not (eolp)))
      (when (looking-at "\\([^:]+\\): *\\(.*\\)")
	(push (cons (downcase (match-string 1))
		    (match-string 2))
	      headers))
      (forward-line 1))
    (unless (eobp)
      (forward-line 1))
    headers))

181 182 183 184 185
(defun eww-detect-charset (html-p)
  (let ((case-fold-search t)
	(pt (point)))
    (or (and html-p
	     (re-search-forward
Ivan Kanis's avatar
Ivan Kanis committed
186
	      "<meta[\t\n\r ]+[^>]*charset=\"?\\([^\t\n\r \"/>]+\\)[\\\"'.*]" nil t)
187 188 189 190 191 192
	     (goto-char pt)
	     (match-string 1))
	(and (looking-at
	      "[\t\n\r ]*<\\?xml[\t\n\r ]+[^>]*encoding=\"\\([^\"]+\\)")
	     (match-string 1)))))

193 194 195 196 197 198 199 200 201
(defun eww-display-html (charset url)
  (unless (eq charset 'utf8)
    (decode-coding-region (point) (point-max) charset))
  (let ((document
	 (list
	  'base (list (cons 'href url))
	  (libxml-parse-html-region (point) (point-max)))))
    (eww-setup-buffer)
    (setq eww-current-url url)
202
    (eww-update-header-line-format)
203
    (let ((inhibit-read-only t)
204
	  (after-change-functions nil)
205
	  (shr-width nil)
206
	  (shr-external-rendering-functions
207 208
	   '((title . eww-tag-title)
	     (form . eww-tag-form)
209
	     (input . eww-tag-input)
210 211
	     (textarea . eww-tag-textarea)
	     (body . eww-tag-body)
212 213 214
	     (select . eww-tag-select)
	     (link . eww-tag-link)
	     (a . eww-tag-a))))
215
      (shr-insert-document document))
216 217
    (goto-char (point-min))))

218 219 220
(defun eww-handle-link (cont)
  (let* ((rel (assq :rel cont))
  	(href (assq :href cont))
221 222 223
	(where (assoc
		;; The text associated with :rel is case-insensitive.
		(if rel (downcase (cdr rel)))
224
		      '(("next" . eww-next-url)
225 226
			;; Texinfo uses "previous", but HTML specifies
			;; "prev", so recognize both.
227
			("previous" . eww-previous-url)
228 229 230 231 232 233 234 235 236
			("prev" . eww-previous-url)
			;; HTML specifies "start" but also "contents",
			;; and Gtk seems to use "home".  Recognize
			;; them all; but store them in different
			;; variables so that we can readily choose the
			;; "best" one.
			("start" . eww-start-url)
			("home" . eww-home-url)
			("contents" . eww-contents-url)
237 238 239 240 241 242 243 244 245 246 247 248 249
			("up" . eww-up-url)))))
    (and href
	 where
	 (set (cdr where) (cdr href)))))

(defun eww-tag-link (cont)
  (eww-handle-link cont)
  (shr-generic cont))

(defun eww-tag-a (cont)
  (eww-handle-link cont)
  (shr-tag-a cont))

250 251
(defun eww-update-header-line-format ()
  (if eww-header-line-format
252 253 254 255 256 257
      (setq header-line-format
	    (replace-regexp-in-string
	     "%" "%%"
	     (format-spec eww-header-line-format
			  `((?u . ,eww-current-url)
			    (?t . ,eww-current-title)))))
258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281
    (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
282
	  (add-face-text-property start end
283 284
				  (list :foreground (cadr new-colors))
				  t))
285
	(when bg
286
	  (add-face-text-property start end
287 288
				  (list :background (car new-colors))
				  t))))))
289

290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305
(defun eww-display-raw (charset)
  (let ((data (buffer-substring (point) (point-max))))
    (eww-setup-buffer)
    (let ((inhibit-read-only t))
      (insert data))
    (goto-char (point-min))))

(defun eww-display-image ()
  (let ((data (buffer-substring (point) (point-max))))
    (eww-setup-buffer)
    (let ((inhibit-read-only t))
      (shr-put-image data nil))
    (goto-char (point-min))))

(defun eww-setup-buffer ()
  (pop-to-buffer (get-buffer-create "*eww*"))
306
  (remove-overlays)
307 308 309 310 311 312 313 314
  (let ((inhibit-read-only t))
    (erase-buffer))
  (eww-mode))

(defvar eww-mode-map
  (let ((map (make-sparse-keymap)))
    (suppress-keymap map)
    (define-key map "q" 'eww-quit)
315
    (define-key map "g" 'eww-reload)
316 317
    (define-key map [tab] 'shr-next-link)
    (define-key map [backtab] 'shr-previous-link)
318 319 320
    (define-key map [delete] 'scroll-down-command)
    (define-key map "\177" 'scroll-down-command)
    (define-key map " " 'scroll-up-command)
321
    (define-key map "l" 'eww-back-url)
322
    (define-key map "f" 'eww-forward-url)
323
    (define-key map "n" 'eww-next-url)
324
    (define-key map "p" 'eww-previous-url)
325 326
    (define-key map "u" 'eww-up-url)
    (define-key map "t" 'eww-top-url)
327 328
    (define-key map "&" 'eww-browse-with-external-browser)
    (define-key map "w" 'eww-copy-page-url)
329 330
    map))

331
(define-derived-mode eww-mode nil "eww"
332 333 334 335
  "Mode for browsing the web.

\\{eww-mode-map}"
  (set (make-local-variable 'eww-current-url) 'author)
336 337 338 339
  (set (make-local-variable 'browse-url-browser-function) 'eww-browse-url)
  (set (make-local-variable 'after-change-functions) 'eww-process-text-input)
  ;;(setq buffer-read-only t)
  )
340

341 342 343 344 345 346 347 348 349 350
(defun eww-save-history ()
  (let ((elem (list :url eww-current-url
		    :point (point)
		    :text (buffer-string))))
    (if (or (zerop eww-history-position)
	    (= eww-history-position (length eww-history)))
	(push elem eww-history)
      (setcdr (nthcdr eww-history-position eww-history)
	      (cons elem (nthcdr eww-history-position eww-history))))))

351
(defun eww-browse-url (url &optional new-window)
352 353
  (when (and (equal major-mode 'eww-mode)
	     eww-current-url)
354
    (eww-save-history))
355
  (eww url))
356 357 358 359 360 361 362

(defun eww-quit ()
  "Exit the Emacs Web Wowser."
  (interactive)
  (setq eww-history nil)
  (kill-buffer (current-buffer)))

363
(defun eww-back-url ()
364 365
  "Go to the previously displayed page."
  (interactive)
366
  (when (>= eww-history-position (length eww-history))
367
    (error "No previous page"))
368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384
  (eww-restore-history
   (if (not (zerop eww-history-position))
       (elt eww-history eww-history-position)
     (eww-save-history)
     (elt eww-history (1+ eww-history-position))))
  (setq eww-history-position (1+ eww-history-position)))

(defun eww-forward-url ()
  "Go to the next displayed page."
  (interactive)
  (when (zerop eww-history-position)
    (error "No next page"))
  (eww-restore-history (elt eww-history (1- eww-history-position)))
  (setq eww-history-position (1- eww-history-position)))

(defun eww-restore-history (elem)
  (let ((inhibit-read-only t))
385
    (erase-buffer)
386 387 388
    (insert (plist-get elem :text))
    (goto-char (plist-get elem :point))
    (setq eww-current-url (plist-get elem :url))))
389

390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418
(defun eww-next-url ()
  "Go to the page marked `next'.
A page is marked `next' if rel=\"next\" appears in a <link>
or <a> tag."
  (interactive)
  (if eww-next-url
      (eww-browse-url (shr-expand-url eww-next-url eww-current-url))
    (error "No `next' on this page")))

(defun eww-previous-url ()
  "Go to the page marked `previous'.
A page is marked `previous' if rel=\"previous\" appears in a <link>
or <a> tag."
  (interactive)
  (if eww-previous-url
      (eww-browse-url (shr-expand-url eww-previous-url eww-current-url))
    (error "No `previous' on this page")))

(defun eww-up-url ()
  "Go to the page marked `up'.
A page is marked `up' if rel=\"up\" appears in a <link>
or <a> tag."
  (interactive)
  (if eww-up-url
      (eww-browse-url (shr-expand-url eww-up-url eww-current-url))
    (error "No `up' on this page")))

(defun eww-top-url ()
  "Go to the page marked `top'.
419 420
A page is marked `top' if rel=\"start\", rel=\"home\", or rel=\"contents\"
appears in a <link> or <a> tag."
421
  (interactive)
422 423 424 425 426 427
  (let ((best-url (or eww-start-url
		      eww-contents-url
		      eww-home-url)))
    (if best-url
	(eww-browse-url (shr-expand-url best-url eww-current-url))
      (error "No `top' for this page"))))
428

429 430 431 432 433 434
(defun eww-reload ()
  "Reload the current page."
  (interactive)
  (url-retrieve eww-current-url 'eww-render
		(list eww-current-url (point))))

435 436 437 438
;; Form support.

(defvar eww-form nil)

439 440 441
(defvar eww-submit-map
  (let ((map (make-sparse-keymap)))
    (define-key map "\r" 'eww-submit)
442
    (define-key map [(control c) (control c)] 'eww-submit)
443 444 445 446 447 448
    map))

(defvar eww-checkbox-map
  (let ((map (make-sparse-keymap)))
    (define-key map [space] 'eww-toggle-checkbox)
    (define-key map "\r" 'eww-toggle-checkbox)
449
    (define-key map [(control c) (control c)] 'eww-submit)
450 451 452 453 454 455 456
    map))

(defvar eww-text-map
  (let ((map (make-keymap)))
    (set-keymap-parent map text-mode-map)
    (define-key map "\r" 'eww-submit)
    (define-key map [(control a)] 'eww-beginning-of-text)
457
    (define-key map [(control c) (control c)] 'eww-submit)
458 459 460 461 462 463 464 465 466
    (define-key map [(control e)] 'eww-end-of-text)
    (define-key map [tab] 'shr-next-link)
    (define-key map [backtab] 'shr-previous-link)
    map))

(defvar eww-textarea-map
  (let ((map (make-keymap)))
    (set-keymap-parent map text-mode-map)
    (define-key map "\r" 'forward-line)
467
    (define-key map [(control c) (control c)] 'eww-submit)
468 469 470 471 472 473 474
    (define-key map [tab] 'shr-next-link)
    (define-key map [backtab] 'shr-previous-link)
    map))

(defvar eww-select-map
  (let ((map (make-sparse-keymap)))
    (define-key map "\r" 'eww-change-select)
475
    (define-key map [(control c) (control c)] 'eww-submit)
476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508
    map))

(defun eww-beginning-of-text ()
  "Move to the start of the input field."
  (interactive)
  (goto-char (eww-beginning-of-field)))

(defun eww-end-of-text ()
  "Move to the end of the text in the input field."
  (interactive)
  (goto-char (eww-end-of-field))
  (let ((start (eww-beginning-of-field)))
    (while (and (equal (following-char) ? )
		(> (point) start))
      (forward-char -1))
    (when (> (point) start)
      (forward-char 1))))

(defun eww-beginning-of-field ()
  (cond
   ((bobp)
    (point))
   ((not (eq (get-text-property (point) 'eww-form)
	     (get-text-property (1- (point)) 'eww-form)))
    (point))
   (t
    (previous-single-property-change
     (point) 'eww-form nil (point-min)))))

(defun eww-end-of-field ()
  (1- (next-single-property-change
       (point) 'eww-form nil (point-max))))

509 510 511 512 513 514 515
(defun eww-tag-form (cont)
  (let ((eww-form
	 (list (assq :method cont)
	       (assq :action cont)))
	(start (point)))
    (shr-ensure-paragraph)
    (shr-generic cont)
516 517 518
    (unless (bolp)
      (insert "\n"))
    (insert "\n")
519 520 521
    (when (> (point) start)
      (put-text-property start (1+ start)
			 'eww-form eww-form))))
522

523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616
(defun eww-form-submit (cont)
  (let ((start (point))
	(value (cdr (assq :value cont))))
    (setq value
	  (if (zerop (length value))
	      "Submit"
	    value))
    (insert value)
    (add-face-text-property start (point) 'eww-form-submit)
    (put-text-property start (point) 'eww-form
		       (list :eww-form eww-form
			     :value value
			     :type "submit"
			     :name (cdr (assq :name cont))))
    (put-text-property start (point) 'keymap eww-submit-map)
    (insert " ")))

(defun eww-form-checkbox (cont)
  (let ((start (point)))
    (if (cdr (assq :checked cont))
	(insert "[X]")
      (insert "[ ]"))
    (add-face-text-property start (point) 'eww-form-checkbox)
    (put-text-property start (point) 'eww-form
		       (list :eww-form eww-form
			     :value (cdr (assq :value cont))
			     :type (downcase (cdr (assq :type cont)))
			     :checked (cdr (assq :checked cont))
			     :name (cdr (assq :name cont))))
    (put-text-property start (point) 'keymap eww-checkbox-map)
    (insert " ")))

(defun eww-form-text (cont)
  (let ((start (point))
	(type (downcase (or (cdr (assq :type cont))
			    "text")))
	(value (or (cdr (assq :value cont)) ""))
	(width (string-to-number
		(or (cdr (assq :size cont))
		    "40"))))
    (insert value)
    (when (< (length value) width)
      (insert (make-string (- width (length value)) ? )))
    (put-text-property start (point) 'face 'eww-form-text)
    (put-text-property start (point) 'local-map eww-text-map)
    (put-text-property start (point) 'inhibit-read-only t)
    (put-text-property start (point) 'eww-form
		       (list :eww-form eww-form
			     :value value
			     :type type
			     :name (cdr (assq :name cont))))
    (insert " ")))

(defun eww-process-text-input (beg end length)
  (let* ((form (get-text-property end 'eww-form))
	 (properties (text-properties-at end))
	 (type (plist-get form :type)))
    (when (and form
	       (member type '("text" "password" "textarea")))
      (cond
       ((zerop length)
	;; Delete some space at the end.
	(save-excursion
	  (goto-char
	   (if (equal type "textarea")
	       (1- (line-end-position))
	     (eww-end-of-field)))
	  (let ((new (- end beg)))
	    (while (and (> new 0)
			(eql (following-char) ? ))
	      (delete-region (point) (1+ (point)))
	      (setq new (1- new))))
	  (set-text-properties beg end properties)))
       ((> length 0)
	;; Add padding.
	(save-excursion
	  (goto-char
	   (if (equal type "textarea")
	       (1- (line-end-position))
	     (eww-end-of-field)))
	  (let ((start (point)))
	    (insert (make-string length ? ))
	    (set-text-properties start (point) properties)))))
      (let ((value (buffer-substring-no-properties
		    (eww-beginning-of-field)
		    (eww-end-of-field))))
	(when (string-match " +\\'" value)
	  (setq value (substring value 0 (match-beginning 0))))
	(plist-put form :value value)
	(when (equal type "password")
	  ;; Display passwords as asterisks.
	  (let ((start (eww-beginning-of-field)))
	    (put-text-property start (+ start (length value))
			       'display (make-string (length value) ?*))))))))
617

618
(defun eww-tag-textarea (cont)
619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680
  (let ((start (point))
	(value (or (cdr (assq :value cont)) ""))
	(lines (string-to-number
		(or (cdr (assq :rows cont))
		    "10")))
	(width (string-to-number
		(or (cdr (assq :cols cont))
		    "10")))
	end)
    (shr-ensure-newline)
    (insert value)
    (shr-ensure-newline)
    (when (< (count-lines start (point)) lines)
      (dotimes (i (- lines (count-lines start (point))))
	(insert "\n")))
    (setq end (point-marker))
    (goto-char start)
    (while (< (point) end)
      (end-of-line)
      (let ((pad (- width (- (point) (line-beginning-position)))))
	(when (> pad 0)
	  (insert (make-string pad ? ))))
      (add-face-text-property (line-beginning-position)
			      (point) 'eww-form-text)
      (put-text-property (line-beginning-position) (point)
			 'local-map eww-textarea-map)
      (forward-line 1))
    (put-text-property start (point) 'eww-form
		       (list :eww-form eww-form
			     :value value
			     :type "textarea"
			     :name (cdr (assq :name cont))))))

(defun eww-tag-input (cont)
  (let ((type (downcase (or (cdr (assq :type cont))
			     "text")))
	(start (point)))
    (cond
     ((or (equal type "checkbox")
	  (equal type "radio"))
      (eww-form-checkbox cont))
     ((equal type "submit")
      (eww-form-submit cont))
     ((equal type "hidden")
      (let ((form eww-form)
	    (name (cdr (assq :name cont))))
	;; Don't add <input type=hidden> elements repeatedly.
	(while (and form
		    (or (not (consp (car form)))
			(not (eq (caar form) 'hidden))
			(not (equal (plist-get (cdr (car form)) :name)
				    name))))
	  (setq form (cdr form)))
	(unless form
	  (nconc eww-form (list
			   (list 'hidden
				 :name name
				 :value (cdr (assq :value cont))))))))
     (t
      (eww-form-text cont)))
    (unless (= start (point))
      (put-text-property start (1+ start) 'help-echo "Input field"))))
681

682 683
(defun eww-tag-select (cont)
  (shr-ensure-paragraph)
684
  (let ((menu (list :name (cdr (assq :name cont))
685 686
		    :eww-form eww-form))
	(options nil)
687 688
	(start (point))
	(max 0))
689 690 691 692 693
    (dolist (elem cont)
      (when (eq (car elem) 'option)
	(when (cdr (assq :selected (cdr elem)))
	  (nconc menu (list :value
			    (cdr (assq :value (cdr elem))))))
694 695 696 697 698 699
	(let ((display (or (cdr (assq 'text (cdr elem))) "")))
	  (setq max (max max (length display)))
	  (push (list 'item
		      :value (cdr (assq :value (cdr elem)))
		      :display display)
		options))))
700
    (when options
701
      (setq options (nreverse options))
702
      ;; If we have no selected values, default to the first value.
703
      (unless (plist-get menu :value)
704 705
	(nconc menu (list :value (nth 2 (car options)))))
      (nconc menu options)
706 707 708 709 710 711
      (let ((selected (eww-select-display menu)))
	(insert selected
		(make-string (- max (length selected)) ? )))
      (put-text-property start (point) 'eww-form menu)
      (add-face-text-property start (point) 'eww-form-select)
      (put-text-property start (point) 'keymap eww-select-map)
712
      (shr-ensure-paragraph))))
713

714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844
(defun eww-select-display (select)
  (let ((value (plist-get select :value))
	display)
    (dolist (elem select)
      (when (and (consp elem)
		 (eq (car elem) 'item)
		 (equal value (plist-get (cdr elem) :value)))
	(setq display (plist-get (cdr elem) :display))))
    display))

(defun eww-change-select ()
  "Change the value of the select drop-down menu under point."
  (interactive)
  (let* ((input (get-text-property (point) 'eww-form))
	 (properties (text-properties-at (point)))
	 (completion-ignore-case t)
	 (options
	  (delq nil
		(mapcar (lambda (elem)
			  (and (consp elem)
			       (eq (car elem) 'item)
			       (cons (plist-get (cdr elem) :display)
				     (plist-get (cdr elem) :value))))
			input)))
	 (display
	  (completing-read "Change value: " options nil 'require-match))
	 (inhibit-read-only t))
    (plist-put input :value (cdr (assoc-string display options t)))
    (goto-char
     (eww-update-field display))))

(defun eww-update-field (string)
  (let ((properties (text-properties-at (point)))
	(start (eww-beginning-of-field))
	(end (1+ (eww-end-of-field))))
    (delete-region start end)
    (insert string
	    (make-string (- (- end start) (length string)) ? ))
    (set-text-properties start end properties)
    start))

(defun eww-toggle-checkbox ()
  "Toggle the value of the checkbox under point."
  (interactive)
  (let* ((input (get-text-property (point) 'eww-form))
	 (type (plist-get input :type)))
    (if (equal type "checkbox")
	(goto-char
	 (1+
	  (if (plist-get input :checked)
	      (progn
		(plist-put input :checked nil)
		(eww-update-field "[ ]"))
	    (plist-put input :checked t)
	    (eww-update-field "[X]"))))
      ;; Radio button.  Switch all other buttons off.
      (let ((name (plist-get input :name)))
	(save-excursion
	  (dolist (elem (eww-inputs (plist-get input :eww-form)))
	    (when (equal (plist-get (cdr elem) :name) name)
	      (goto-char (car elem))
	      (if (not (eq (cdr elem) input))
		  (progn
		    (plist-put input :checked nil)
		    (eww-update-field "[ ]"))
		(plist-put input :checked t)
		(eww-update-field "[X]")))))
	(forward-char 1)))))

(defun eww-inputs (form)
  (let ((start (point-min))
	(inputs nil))
    (while (and start
		(< start (point-max)))
      (when (or (get-text-property start 'eww-form)
		(setq start (next-single-property-change start 'eww-form)))
	(when (eq (plist-get (get-text-property start 'eww-form) :eww-form)
		  form)
	  (push (cons start (get-text-property start 'eww-form))
		inputs))
	(setq start (next-single-property-change start 'eww-form))))
    (nreverse inputs)))

(defun eww-input-value (input)
  (let ((type (plist-get input :type))
	(value (plist-get input :value)))
    (cond
     ((equal type "textarea")
      (with-temp-buffer
	(insert value)
	(goto-char (point-min))
	(while (re-search-forward "^ +\n\\| +$" nil t)
	  (replace-match "" t t))
	(buffer-string)))
     (t
      (if (string-match " +\\'" value)
	  (substring value 0 (match-beginning 0))
	value)))))

(defun eww-submit ()
  "Submit the current form."
  (interactive)
  (let* ((this-input (get-text-property (point) 'eww-form))
	 (form (plist-get this-input :eww-form))
	 values next-submit)
    (dolist (elem (sort (eww-inputs form)
			 (lambda (o1 o2)
			   (< (car o1) (car o2)))))
      (let* ((input (cdr elem))
	     (input-start (car elem))
	     (name (plist-get input :name)))
	(when name
	  (cond
	   ((member (plist-get input :type) '("checkbox" "radio"))
	    (when (plist-get input :checked)
	      (push (cons name (plist-get input :value))
		    values)))
	   ((equal (plist-get input :type) "submit")
	    ;; We want the values from buttons if we hit a button if
	    ;; we hit enter on it, or if it's the first button after
	    ;; the field we did hit return on.
	    (when (or (eq input this-input)
		      (and (not (eq input this-input))
			   (null next-submit)
			   (> input-start (point))))
	      (setq next-submit t)
	      (push (cons name (plist-get input :value))
		    values)))
	   (t
	    (push (cons name (eww-input-value input))
		  values))))))
845 846 847 848 849 850
    (dolist (elem form)
      (when (and (consp elem)
		 (eq (car elem) 'hidden))
	(push (cons (plist-get (cdr elem) :name)
		    (plist-get (cdr elem) :value))
	      values)))
851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866
    (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))))))
867

868 869
(defun eww-browse-with-external-browser ()
  "Browse the current URL with an external browser.
870
The browser to used is specified by the `shr-external-browser' variable."
871
  (interactive)
872
  (funcall shr-external-browser eww-current-url))
873

874
(defun eww-copy-page-url ()
Ivan Kanis's avatar
Ivan Kanis committed
875
  (interactive)
876
  (message "%s" eww-current-url)
Ivan Kanis's avatar
Ivan Kanis committed
877
  (kill-new eww-current-url))
878

879 880 881
(provide 'eww)

;;; eww.el ends here