code.delx.au - gnu-emacs/blob - lisp/net/eww.el

   1 ;;; eww.el --- Emacs Web Wowser
   2
   3 ;; Copyright (C) 2013-2014 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 'format-spec)
  29 (require 'shr)
  30 (require 'url)
  31 (require 'url-queue)
  32 (require 'mm-url)
  33 (eval-when-compile (require 'subr-x)) ;; for string-trim
  34
  35 (defgroup eww nil
  36   "Emacs Web Wowser"
  37   :version "25.1"
  38   :link '(custom-manual "(eww) Top")
  39   :group 'web
  40   :prefix "eww-")
  41
  42 (defcustom eww-header-line-format "%t: %u"
  43   "Header line format.
  44 - %t is replaced by the title.
  45 - %u is replaced by the URL."
  46   :version "24.4"
  47   :group 'eww
  48   :type 'string)
  49
  50 (defcustom eww-search-prefix "https://duckduckgo.com/html/?q="
  51   "Prefix URL to search engine"
  52   :version "24.4"
  53   :group 'eww
  54   :type 'string)
  55
  56 (defcustom eww-download-directory "~/Downloads/"
  57   "Directory where files will downloaded."
  58   :version "24.4"
  59   :group 'eww
  60   :type 'string)
  61
  62 (defcustom eww-bookmarks-directory user-emacs-directory
  63   "Directory where bookmark files will be stored."
  64   :version "25.1"
  65   :group 'eww
  66   :type 'string)
  67
  68 (defcustom eww-desktop-remove-duplicates t
  69   "Whether to remove duplicates from the history when saving desktop data.
  70 If non-nil, repetitive EWW history entries (comprising of the URI, the
  71 title, and the point position) will not be saved as part of the Emacs
  72 desktop.  Otherwise, such entries will be retained."
  73   :version "25.1"
  74   :group 'eww
  75   :type 'boolean)
  76
  77 (defcustom eww-restore-desktop nil
  78   "How to restore EWW buffers on `desktop-restore'.
  79 If t or 'auto, the buffers will be reloaded automatically.
  80 If nil, buffers will require manual reload, and will contain the text
  81 specified in `eww-restore-reload-prompt' instead of the actual Web
  82 page contents."
  83   :version "25.1"
  84   :group 'eww
  85   :type '(choice (const :tag "Restore all automatically" t)
  86                  (const :tag "Require manual reload" nil)))
  87
  88 (defcustom eww-restore-reload-prompt
  89   "\n\n *** Use \\[eww-reload] to reload this buffer. ***\n"
  90   "The string to put in the buffers not reloaded on `desktop-restore'.
  91 This prompt will be used if `eww-restore-desktop' is nil.
  92
  93 The string will be passed through `substitute-command-keys'."
  94   :version "25.1"
  95   :group 'eww
  96   :type 'string)
  97
  98 (defcustom eww-history-limit 50
  99   "Maximum number of entries to retain in the history."
 100   :version "25.1"
 101   :group 'eww
 102   :type '(choice (const :tag "Unlimited" nil)
 103                  integer))
 104 (defcustom eww-use-external-browser-for-content-type
 105   "\\`\\(video/\\|audio/\\|application/ogg\\)"
 106   "Always use external browser for specified content-type."
 107   :version "24.4"
 108   :group 'eww
 109   :type '(choice (const :tag "Never" nil)
 110                  regexp))
 111
 112 (defcustom eww-after-render-hook nil
 113   "A hook called after eww has finished rendering the buffer."
 114   :version "25.1"
 115   :group 'eww
 116   :type 'hook)
 117
 118 (defcustom eww-form-checkbox-selected-symbol "[X]"
 119   "Symbol used to represent a selected checkbox.
 120 See also `eww-form-checkbox-symbol'."
 121   :version "24.4"
 122   :group 'eww
 123   :type '(choice (const "[X]")
 124                  (const "☒")            ; Unicode BALLOT BOX WITH X
 125                  (const "☑")            ; Unicode BALLOT BOX WITH CHECK
 126                  string))
 127
 128 (defcustom eww-form-checkbox-symbol "[ ]"
 129   "Symbol used to represent a checkbox.
 130 See also `eww-form-checkbox-selected-symbol'."
 131   :version "24.4"
 132   :group 'eww
 133   :type '(choice (const "[ ]")
 134                  (const "☐")            ; Unicode BALLOT BOX
 135                  string))
 136
 137 (defface eww-form-submit
 138   '((((type x w32 ns) (class color))    ; Like default mode line
 139      :box (:line-width 2 :style released-button)
 140      :background "#808080" :foreground "black"))
 141   "Face for eww buffer buttons."
 142   :version "24.4"
 143   :group 'eww)
 144
 145 (defface eww-form-file
 146   '((((type x w32 ns) (class color))    ; Like default mode line
 147      :box (:line-width 2 :style released-button)
 148      :background "#808080" :foreground "black"))
 149   "Face for eww buffer buttons."
 150   :version "25.1"
 151   :group 'eww)
 152
 153 (defface eww-form-checkbox
 154   '((((type x w32 ns) (class color))    ; Like default mode line
 155      :box (:line-width 2 :style released-button)
 156      :background "lightgrey" :foreground "black"))
 157   "Face for eww buffer buttons."
 158   :version "24.4"
 159   :group 'eww)
 160
 161 (defface eww-form-select
 162   '((((type x w32 ns) (class color))    ; Like default mode line
 163      :box (:line-width 2 :style released-button)
 164      :background "lightgrey" :foreground "black"))
 165   "Face for eww buffer buttons."
 166   :version "24.4"
 167   :group 'eww)
 168
 169 (defface eww-form-text
 170   '((t (:background "#505050"
 171                     :foreground "white"
 172                     :box (:line-width 1))))
 173   "Face for eww text inputs."
 174   :version "24.4"
 175   :group 'eww)
 176
 177 (defface eww-form-textarea
 178   '((t (:background "#C0C0C0"
 179                     :foreground "black"
 180                     :box (:line-width 1))))
 181   "Face for eww textarea inputs."
 182   :version "24.4"
 183   :group 'eww)
 184
 185 (defvar eww-data nil)
 186 (defvar eww-history nil)
 187 (defvar eww-history-position 0)
 188
 189 (defvar eww-local-regex "localhost"
 190   "When this regex is found in the URL, it's not a keyword but an address.")
 191
 192 (defvar eww-link-keymap
 193   (let ((map (copy-keymap shr-map)))
 194     (define-key map "\r" 'eww-follow-link)
 195     map))
 196
 197 ;;;###autoload
 198 (defun eww (url)
 199   "Fetch URL and render the page.
 200 If the input doesn't look like an URL or a domain name, the
 201 word(s) will be searched for via `eww-search-prefix'."
 202   (interactive "sEnter URL or keywords: ")
 203   (setq url (string-trim url))
 204   (cond ((string-match-p "\\`file:/" url))
 205         ;; Don't mangle file: URLs at all.
 206         ((string-match-p "\\`ftp://" url)
 207          (user-error "FTP is not supported."))
 208         (t
 209          (if (and (= (length (split-string url)) 1)
 210                   (or (and (not (string-match-p "\\`[\"\'].*[\"\']\\'" url))
 211                            (> (length (split-string url "[.:]")) 1))
 212                       (string-match eww-local-regex url)))
 213              (progn
 214                (unless (string-match-p "\\`[a-zA-Z][-a-zA-Z0-9+.]*://" url)
 215                  (setq url (concat "http://" url)))
 216                ;; some site don't redirect final /
 217                (when (string= (url-filename (url-generic-parse-url url)) "")
 218                  (setq url (concat url "/"))))
 219            (setq url (concat eww-search-prefix
 220                              (replace-regexp-in-string " " "+" url))))))
 221   (url-retrieve url 'eww-render
 222                 (list url nil
 223                       (and (eq major-mode 'eww-mode)
 224                            (current-buffer)))))
 225
 226 ;;;###autoload (defalias 'browse-web 'eww)
 227
 228 ;;;###autoload
 229 (defun eww-open-file (file)
 230   "Render a file using EWW."
 231   (interactive "fFile: ")
 232   (eww (concat "file://"
 233                (and (memq system-type '(windows-nt ms-dos))
 234                     "/")
 235                (expand-file-name file))))
 236
 237 ;;;###autoload
 238 (defun eww-search-words (&optional beg end)
 239   "Search the web for the text between the point and marker.
 240 See the `eww-search-prefix' variable for the search engine used."
 241   (interactive "r")
 242   (eww (buffer-substring beg end)))
 243
 244 (defun eww-render (status url &optional point buffer)
 245   (let ((redirect (plist-get status :redirect)))
 246     (when redirect
 247       (setq url redirect)))
 248   (let* ((headers (eww-parse-headers))
 249          (content-type
 250           (mail-header-parse-content-type
 251            (or (cdr (assoc "content-type" headers))
 252                "text/plain")))
 253          (charset (intern
 254                    (downcase
 255                     (or (cdr (assq 'charset (cdr content-type)))
 256                         (eww-detect-charset (equal (car content-type)
 257                                                    "text/html"))
 258                         "utf8"))))
 259          (data-buffer (current-buffer)))
 260     (unwind-protect
 261         (progn
 262           (plist-put eww-data :title "")
 263           (cond
 264            ((and eww-use-external-browser-for-content-type
 265                  (string-match-p eww-use-external-browser-for-content-type
 266                                  (car content-type)))
 267             (eww-browse-with-external-browser url))
 268            ((equal (car content-type) "text/html")
 269             (eww-display-html charset url nil point buffer))
 270            ((equal (car content-type) "application/pdf")
 271             (eww-display-pdf))
 272            ((string-match-p "\\`image/" (car content-type))
 273             (eww-display-image buffer)
 274             (eww-update-header-line-format))
 275            (t
 276             (eww-display-raw buffer)
 277             (eww-update-header-line-format)))
 278           (plist-put eww-data :url url)
 279           (setq eww-history-position 0)
 280           (run-hooks 'eww-after-render-hook))
 281       (kill-buffer data-buffer))))
 282
 283 (defun eww-parse-headers ()
 284   (let ((headers nil))
 285     (goto-char (point-min))
 286     (while (and (not (eobp))
 287                 (not (eolp)))
 288       (when (looking-at "\\([^:]+\\): *\\(.*\\)")
 289         (push (cons (downcase (match-string 1))
 290                     (match-string 2))
 291               headers))
 292       (forward-line 1))
 293     (unless (eobp)
 294       (forward-line 1))
 295     headers))
 296
 297 (defun eww-detect-charset (html-p)
 298   (let ((case-fold-search t)
 299         (pt (point)))
 300     (or (and html-p
 301              (re-search-forward
 302               "<meta[\t\n\r ]+[^>]*charset=\"?\\([^\t\n\r \"/>]+\\)[\\\"'.*]" nil t)
 303              (goto-char pt)
 304              (match-string 1))
 305         (and (looking-at
 306               "[\t\n\r ]*<\\?xml[\t\n\r ]+[^>]*encoding=\"\\([^\"]+\\)")
 307              (match-string 1)))))
 308
 309 (declare-function libxml-parse-html-region "xml.c"
 310                   (start end &optional base-url))
 311
 312 (defun eww-display-html (charset url &optional document point buffer)
 313   (or (fboundp 'libxml-parse-html-region)
 314       (error "This function requires Emacs to be compiled with libxml2"))
 315   ;; There should be a better way to abort loading images
 316   ;; asynchronously.
 317   (setq url-queue nil)
 318   (let ((document
 319          (or document
 320              (list
 321               'base (list (cons 'href url))
 322               (progn
 323                 (unless (eq charset 'utf-8)
 324                   (condition-case nil
 325                       (decode-coding-region (point) (point-max) charset)
 326                     (coding-system-error nil)))
 327                 (libxml-parse-html-region (point) (point-max))))))
 328         (source (and (null document)
 329                      (buffer-substring (point) (point-max)))))
 330     (eww-setup-buffer buffer)
 331     (plist-put eww-data :source source)
 332     (plist-put eww-data :dom document)
 333     (let ((inhibit-read-only t)
 334           (after-change-functions nil)
 335           (shr-target-id (url-target (url-generic-parse-url url)))
 336           (shr-external-rendering-functions
 337            '((title . eww-tag-title)
 338              (form . eww-tag-form)
 339              (input . eww-tag-input)
 340              (textarea . eww-tag-textarea)
 341              (body . eww-tag-body)
 342              (select . eww-tag-select)
 343              (link . eww-tag-link)
 344              (a . eww-tag-a))))
 345       (shr-insert-document document)
 346       (cond
 347        (point
 348         (goto-char point))
 349        (shr-target-id
 350         (goto-char (point-min))
 351         (let ((point (next-single-property-change
 352                       (point-min) 'shr-target-id)))
 353           (when point
 354             (goto-char point))))
 355        (t
 356         (goto-char (point-min))
 357         ;; Don't leave point inside forms, because the normal eww
 358         ;; commands aren't available there.
 359         (while (and (not (eobp))
 360                     (get-text-property (point) 'eww-form))
 361           (forward-line 1)))))
 362     (plist-put eww-data :url url)
 363     (setq eww-history-position 0)
 364     (eww-update-header-line-format)))
 365
 366 (defun eww-handle-link (cont)
 367   (let* ((rel (assq :rel cont))
 368         (href (assq :href cont))
 369         (where (assoc
 370                 ;; The text associated with :rel is case-insensitive.
 371                 (if rel (downcase (cdr rel)))
 372                       '(("next" . :next)
 373                         ;; Texinfo uses "previous", but HTML specifies
 374                         ;; "prev", so recognize both.
 375                         ("previous" . :previous)
 376                         ("prev" . :previous)
 377                         ;; HTML specifies "start" but also "contents",
 378                         ;; and Gtk seems to use "home".  Recognize
 379                         ;; them all; but store them in different
 380                         ;; variables so that we can readily choose the
 381                         ;; "best" one.
 382                         ("start" . :start)
 383                         ("home" . :home)
 384                         ("contents" . :contents)
 385                         ("up" . up)))))
 386     (and href
 387          where
 388          (plist-put eww-data (cdr where) (cdr href)))))
 389
 390 (defun eww-tag-link (cont)
 391   (eww-handle-link cont)
 392   (shr-generic cont))
 393
 394 (defun eww-tag-a (cont)
 395   (eww-handle-link cont)
 396   (let ((start (point)))
 397     (shr-tag-a cont)
 398     (put-text-property start (point) 'keymap eww-link-keymap)))
 399
 400 (defun eww-update-header-line-format ()
 401   (if eww-header-line-format
 402       (setq header-line-format
 403             (replace-regexp-in-string
 404              "%" "%%"
 405              ;; FIXME?  Title can be blank.  Default to, eg, last component
 406              ;; of url?
 407              (format-spec eww-header-line-format
 408                           `((?u . ,(plist-get eww-data :url))
 409                             (?t . ,(or (plist-get eww-data :title) ""))))))
 410     (setq header-line-format nil)))
 411
 412 (defun eww-tag-title (cont)
 413   (let ((title ""))
 414     (dolist (sub cont)
 415       (when (eq (car sub) 'text)
 416         (setq title (concat title (cdr sub)))))
 417     (plist-put eww-data :title
 418                (replace-regexp-in-string
 419                 "^ \\| $" ""
 420                 (replace-regexp-in-string "[ \t\r\n]+" " " title))))
 421   (eww-update-header-line-format))
 422
 423 (defun eww-tag-body (cont)
 424   (let* ((start (point))
 425          (fgcolor (cdr (or (assq :fgcolor cont)
 426                            (assq :text cont))))
 427          (bgcolor (cdr (assq :bgcolor cont)))
 428          (shr-stylesheet (list (cons 'color fgcolor)
 429                                (cons 'background-color bgcolor))))
 430     (shr-generic cont)
 431     (shr-colorize-region start (point) fgcolor bgcolor)))
 432
 433 (defun eww-display-raw (&optional buffer)
 434   (let ((data (buffer-substring (point) (point-max))))
 435     (eww-setup-buffer buffer)
 436     (let ((inhibit-read-only t))
 437       (insert data))
 438     (goto-char (point-min))))
 439
 440 (defun eww-display-image (&optional buffer)
 441   (let ((data (shr-parse-image-data)))
 442     (eww-setup-buffer buffer)
 443     (let ((inhibit-read-only t))
 444       (shr-put-image data nil))
 445     (goto-char (point-min))))
 446
 447 (defun eww-display-pdf ()
 448   (let ((data (buffer-substring (point) (point-max))))
 449     (switch-to-buffer (get-buffer-create "*eww pdf*"))
 450     (let ((coding-system-for-write 'raw-text)
 451           (inhibit-read-only t))
 452       (erase-buffer)
 453       (insert data)
 454       (doc-view-mode)))
 455   (goto-char (point-min)))
 456
 457 (defun eww-setup-buffer (&optional buffer)
 458   (switch-to-buffer
 459    (if (buffer-live-p buffer)
 460        buffer
 461      (get-buffer-create "*eww*")))
 462   (let ((inhibit-read-only t))
 463     (remove-overlays)
 464     (erase-buffer))
 465   (unless (eq major-mode 'eww-mode)
 466     (eww-mode)))
 467
 468 (defun eww-view-source ()
 469   "View the HTML source code of the current page."
 470   (interactive)
 471   (let ((buf (get-buffer-create "*eww-source*"))
 472         (source (plist-get eww-data :source)))
 473     (with-current-buffer buf
 474       (let ((inhibit-read-only t))
 475         (delete-region (point-min) (point-max))
 476         (insert (or source "no source"))
 477         (goto-char (point-min))
 478         (when (fboundp 'html-mode)
 479           (html-mode))))
 480     (view-buffer buf)))
 481
 482 (defun eww-readable ()
 483   "View the main \"readable\" parts of the current web page.
 484 This command uses heuristics to find the parts of the web page that
 485 contains the main textual portion, leaving out navigation menus and
 486 the like."
 487   (interactive)
 488   (let* ((old-data eww-data)
 489          (dom (shr-transform-dom
 490                (with-temp-buffer
 491                  (insert (plist-get old-data :source))
 492                  (condition-case nil
 493                      (decode-coding-region (point-min) (point-max) 'utf-8)
 494                    (coding-system-error nil))
 495                  (libxml-parse-html-region (point-min) (point-max))))))
 496     (eww-score-readability dom)
 497     (eww-save-history)
 498     (eww-display-html nil nil
 499                       (shr-retransform-dom
 500                        (eww-highest-readability dom))
 501                       nil (current-buffer))
 502     (dolist (elem '(:source :url :title :next :previous :up))
 503       (plist-put eww-data elem (plist-get old-data elem)))
 504     (eww-update-header-line-format)))
 505
 506 (defun eww-score-readability (node)
 507   (let ((score -1))
 508     (cond
 509      ((memq (car node) '(script head comment))
 510       (setq score -2))
 511      ((eq (car node) 'meta)
 512       (setq score -1))
 513      ((eq (car node) 'img)
 514       (setq score 2))
 515      ((eq (car node) 'a)
 516       (setq score (- (length (split-string
 517                               (or (cdr (assoc 'text (cdr node))) ""))))))
 518      (t
 519       (dolist (elem (cdr node))
 520         (cond
 521          ((and (stringp (cdr elem))
 522                (eq (car elem) 'text))
 523           (setq score (+ score (length (split-string (cdr elem))))))
 524          ((consp (cdr elem))
 525           (setq score (+ score
 526                          (or (cdr (assoc :eww-readability-score (cdr elem)))
 527                              (eww-score-readability elem)))))))))
 528     ;; Cache the score of the node to avoid recomputing all the time.
 529     (setcdr node (cons (cons :eww-readability-score score) (cdr node)))
 530     score))
 531
 532 (defun eww-highest-readability (node)
 533   (let ((result node)
 534         highest)
 535     (dolist (elem (cdr node))
 536       (when (and (consp (cdr elem))
 537                  (> (or (cdr (assoc
 538                               :eww-readability-score
 539                               (setq highest
 540                                     (eww-highest-readability elem))))
 541                         most-negative-fixnum)
 542                     (or (cdr (assoc :eww-readability-score (cdr result)))
 543                         most-negative-fixnum)))
 544         (setq result highest)))
 545     result))
 546
 547 (defvar eww-mode-map
 548   (let ((map (make-sparse-keymap)))
 549     (suppress-keymap map)
 550     (define-key map "q" 'quit-window)
 551     (define-key map "g" 'eww-reload)
 552     (define-key map [?\t] 'shr-next-link)
 553     (define-key map [?\M-\t] 'shr-previous-link)
 554     (define-key map [delete] 'scroll-down-command)
 555     (define-key map [?\S-\ ] 'scroll-down-command)
 556     (define-key map "\177" 'scroll-down-command)
 557     (define-key map " " 'scroll-up-command)
 558     (define-key map "l" 'eww-back-url)
 559     (define-key map "r" 'eww-forward-url)
 560     (define-key map "n" 'eww-next-url)
 561     (define-key map "p" 'eww-previous-url)
 562     (define-key map "u" 'eww-up-url)
 563     (define-key map "t" 'eww-top-url)
 564     (define-key map "&" 'eww-browse-with-external-browser)
 565     (define-key map "d" 'eww-download)
 566     (define-key map "w" 'eww-copy-page-url)
 567     (define-key map "C" 'url-cookie-list)
 568     (define-key map "v" 'eww-view-source)
 569     (define-key map "R" 'eww-readable)
 570     (define-key map "H" 'eww-list-histories)
 571
 572     (define-key map "b" 'eww-add-bookmark)
 573     (define-key map "B" 'eww-list-bookmarks)
 574     (define-key map [(meta n)] 'eww-next-bookmark)
 575     (define-key map [(meta p)] 'eww-previous-bookmark)
 576
 577     (easy-menu-define nil map ""
 578       '("Eww"
 579         ["Exit" quit-window t]
 580         ["Close browser" quit-window t]
 581         ["Reload" eww-reload t]
 582         ["Back to previous page" eww-back-url
 583          :active (not (zerop (length eww-history)))]
 584         ["Forward to next page" eww-forward-url
 585          :active (not (zerop eww-history-position))]
 586         ["Browse with external browser" eww-browse-with-external-browser t]
 587         ["Download" eww-download t]
 588         ["View page source" eww-view-source]
 589         ["Copy page URL" eww-copy-page-url t]
 590         ["List histories" eww-list-histories t]
 591         ["Add bookmark" eww-add-bookmark t]
 592         ["List bookmarks" eww-list-bookmarks t]
 593         ["List cookies" url-cookie-list t]))
 594     map))
 595
 596 (defvar eww-tool-bar-map
 597   (let ((map (make-sparse-keymap)))
 598     (dolist (tool-bar-item
 599              '((quit-window . "close")
 600                (eww-reload . "refresh")
 601                (eww-back-url . "left-arrow")
 602                (eww-forward-url . "right-arrow")
 603                (eww-view-source . "show")
 604                (eww-copy-page-url . "copy")
 605                (eww-add-bookmark . "bookmark_add"))) ;; ...
 606       (tool-bar-local-item-from-menu
 607        (car tool-bar-item) (cdr tool-bar-item) map eww-mode-map))
 608     map)
 609   "Tool bar for `eww-mode'.")
 610
 611 (define-derived-mode eww-mode nil "eww"
 612   "Mode for browsing the web.
 613
 614 \\{eww-mode-map}"
 615   (setq-local eww-data (list :title ""))
 616   (setq-local browse-url-browser-function 'eww-browse-url)
 617   (setq-local after-change-functions 'eww-process-text-input)
 618   (setq-local eww-history nil)
 619   (setq-local eww-history-position 0)
 620   (when (boundp 'tool-bar-map)
 621    (setq-local tool-bar-map eww-tool-bar-map))
 622   ;; desktop support
 623   (setq-local desktop-save-buffer 'eww-desktop-misc-data)
 624   (buffer-disable-undo)
 625   (setq buffer-read-only t))
 626
 627 ;;;###autoload
 628 (defun eww-browse-url (url &optional _new-window)
 629   (when (and (equal major-mode 'eww-mode)
 630              (plist-get eww-data :url))
 631     (eww-save-history))
 632   (eww url))
 633
 634 (defun eww-back-url ()
 635   "Go to the previously displayed page."
 636   (interactive)
 637   (when (>= eww-history-position (length eww-history))
 638     (user-error "No previous page"))
 639   (eww-save-history)
 640   (setq eww-history-position (+ eww-history-position 2))
 641   (eww-restore-history (elt eww-history (1- eww-history-position))))
 642
 643 (defun eww-forward-url ()
 644   "Go to the next displayed page."
 645   (interactive)
 646   (when (zerop eww-history-position)
 647     (user-error "No next page"))
 648   (eww-save-history)
 649   (eww-restore-history (elt eww-history (1- eww-history-position))))
 650
 651 (defun eww-restore-history (elem)
 652   (let ((inhibit-read-only t)
 653         (text (plist-get elem :text)))
 654     (setq eww-data elem)
 655     (if (null text)
 656         (eww-reload)                    ; FIXME: restore :point?
 657       (erase-buffer)
 658       (insert text)
 659       (goto-char (plist-get elem :point))
 660       (eww-update-header-line-format))))
 661
 662 (defun eww-next-url ()
 663   "Go to the page marked `next'.
 664 A page is marked `next' if rel=\"next\" appears in a <link>
 665 or <a> tag."
 666   (interactive)
 667   (if (plist-get eww-data :next)
 668       (eww-browse-url (shr-expand-url (plist-get eww-data :next)
 669                                       (plist-get eww-data :url)))
 670     (user-error "No `next' on this page")))
 671
 672 (defun eww-previous-url ()
 673   "Go to the page marked `previous'.
 674 A page is marked `previous' if rel=\"previous\" appears in a <link>
 675 or <a> tag."
 676   (interactive)
 677   (if (plist-get eww-data :previous)
 678       (eww-browse-url (shr-expand-url (plist-get eww-data :previous)
 679                                       (plist-get eww-data :url)))
 680     (user-error "No `previous' on this page")))
 681
 682 (defun eww-up-url ()
 683   "Go to the page marked `up'.
 684 A page is marked `up' if rel=\"up\" appears in a <link>
 685 or <a> tag."
 686   (interactive)
 687   (if (plist-get eww-data :up)
 688       (eww-browse-url (shr-expand-url (plist-get eww-data :up)
 689                                       (plist-get eww-data :url)))
 690     (user-error "No `up' on this page")))
 691
 692 (defun eww-top-url ()
 693   "Go to the page marked `top'.
 694 A page is marked `top' if rel=\"start\", rel=\"home\", or rel=\"contents\"
 695 appears in a <link> or <a> tag."
 696   (interactive)
 697   (let ((best-url (or (plist-get eww-data :start)
 698                       (plist-get eww-data :contents)
 699                       (plist-get eww-data :home))))
 700     (if best-url
 701         (eww-browse-url (shr-expand-url best-url (plist-get eww-data :url)))
 702       (user-error "No `top' for this page"))))
 703
 704 (defun eww-reload ()
 705   "Reload the current page."
 706   (interactive)
 707   (let ((url (plist-get eww-data :url)))
 708     (url-retrieve url 'eww-render
 709                   (list url (point) (current-buffer)))))
 710
 711 ;; Form support.
 712
 713 (defvar eww-form nil)
 714
 715 (defvar eww-submit-map
 716   (let ((map (make-sparse-keymap)))
 717     (define-key map "\r" 'eww-submit)
 718     (define-key map [(control c) (control c)] 'eww-submit)
 719     map))
 720
 721 (defvar eww-submit-file
 722   (let ((map (make-sparse-keymap)))
 723     (define-key map "\r" 'eww-select-file)
 724     (define-key map [(control c) (control c)] 'eww-submit)
 725     map))
 726
 727 (defvar eww-checkbox-map
 728   (let ((map (make-sparse-keymap)))
 729     (define-key map " " 'eww-toggle-checkbox)
 730     (define-key map "\r" 'eww-toggle-checkbox)
 731     (define-key map [(control c) (control c)] 'eww-submit)
 732     map))
 733
 734 (defvar eww-text-map
 735   (let ((map (make-keymap)))
 736     (set-keymap-parent map text-mode-map)
 737     (define-key map "\r" 'eww-submit)
 738     (define-key map [(control a)] 'eww-beginning-of-text)
 739     (define-key map [(control c) (control c)] 'eww-submit)
 740     (define-key map [(control e)] 'eww-end-of-text)
 741     (define-key map [?\t] 'shr-next-link)
 742     (define-key map [?\M-\t] 'shr-previous-link)
 743     map))
 744
 745 (defvar eww-textarea-map
 746   (let ((map (make-keymap)))
 747     (set-keymap-parent map text-mode-map)
 748     (define-key map "\r" 'forward-line)
 749     (define-key map [(control c) (control c)] 'eww-submit)
 750     (define-key map [?\t] 'shr-next-link)
 751     (define-key map [?\M-\t] 'shr-previous-link)
 752     map))
 753
 754 (defvar eww-select-map
 755   (let ((map (make-sparse-keymap)))
 756     (define-key map "\r" 'eww-change-select)
 757     (define-key map [(control c) (control c)] 'eww-submit)
 758     map))
 759
 760 (defun eww-beginning-of-text ()
 761   "Move to the start of the input field."
 762   (interactive)
 763   (goto-char (eww-beginning-of-field)))
 764
 765 (defun eww-end-of-text ()
 766   "Move to the end of the text in the input field."
 767   (interactive)
 768   (goto-char (eww-end-of-field))
 769   (let ((start (eww-beginning-of-field)))
 770     (while (and (equal (following-char) ? )
 771                 (> (point) start))
 772       (forward-char -1))
 773     (when (> (point) start)
 774       (forward-char 1))))
 775
 776 (defun eww-beginning-of-field ()
 777   (cond
 778    ((bobp)
 779     (point))
 780    ((not (eq (get-text-property (point) 'eww-form)
 781              (get-text-property (1- (point)) 'eww-form)))
 782     (point))
 783    (t
 784     (previous-single-property-change
 785      (point) 'eww-form nil (point-min)))))
 786
 787 (defun eww-end-of-field ()
 788   (1- (next-single-property-change
 789        (point) 'eww-form nil (point-max))))
 790
 791 (defun eww-tag-form (cont)
 792   (let ((eww-form
 793          (list (assq :method cont)
 794                (assq :action cont)))
 795         (start (point)))
 796     (shr-ensure-paragraph)
 797     (shr-generic cont)
 798     (unless (bolp)
 799       (insert "\n"))
 800     (insert "\n")
 801     (when (> (point) start)
 802       (put-text-property start (1+ start)
 803                          'eww-form eww-form))))
 804
 805 (defun eww-form-submit (cont)
 806   (let ((start (point))
 807         (value (cdr (assq :value cont))))
 808     (setq value
 809           (if (zerop (length value))
 810               "Submit"
 811             value))
 812     (insert value)
 813     (add-face-text-property start (point) 'eww-form-submit)
 814     (put-text-property start (point) 'eww-form
 815                        (list :eww-form eww-form
 816                              :value value
 817                              :type "submit"
 818                              :name (cdr (assq :name cont))))
 819     (put-text-property start (point) 'keymap eww-submit-map)
 820     (insert " ")))
 821
 822 (defun eww-form-checkbox (cont)
 823   (let ((start (point)))
 824     (if (cdr (assq :checked cont))
 825         (insert eww-form-checkbox-selected-symbol)
 826       (insert eww-form-checkbox-symbol))
 827     (add-face-text-property start (point) 'eww-form-checkbox)
 828     (put-text-property start (point) 'eww-form
 829                        (list :eww-form eww-form
 830                              :value (cdr (assq :value cont))
 831                              :type (downcase (cdr (assq :type cont)))
 832                              :checked (cdr (assq :checked cont))
 833                              :name (cdr (assq :name cont))))
 834     (put-text-property start (point) 'keymap eww-checkbox-map)
 835     (insert " ")))
 836
 837 (defun eww-form-file (cont)
 838   (let ((start (point))
 839         (value (cdr (assq :value cont))))
 840     (setq value
 841           (if (zerop (length value))
 842               " No file selected"
 843             value))
 844     (insert "Browse")
 845     (add-face-text-property start (point) 'eww-form-file)
 846     (insert value)
 847     (put-text-property start (point) 'eww-form
 848                        (list :eww-form eww-form
 849                              :value (cdr (assq :value cont))
 850                              :type (downcase (cdr (assq :type cont)))
 851                              :name (cdr (assq :name cont))))
 852     (put-text-property start (point) 'keymap eww-submit-file)
 853     (insert " ")))
 854
 855 (defun eww-select-file ()
 856   "Change the value of the upload file menu under point."
 857   (interactive)
 858   (let*  ((input (get-text-property (point) 'eww-form)))
 859     (let ((filename
 860            (let ((insert-default-directory t))
 861              (read-file-name "filename:  "))))
 862       (eww-update-field filename (length "Browse"))
 863               (plist-put input :filename filename))))
 864
 865 (defun eww-form-text (cont)
 866   (let ((start (point))
 867         (type (downcase (or (cdr (assq :type cont))
 868                             "text")))
 869         (value (or (cdr (assq :value cont)) ""))
 870         (width (string-to-number
 871                 (or (cdr (assq :size cont))
 872                     "40")))
 873         (readonly-property (if (or (cdr (assq :disabled cont))
 874                                    (cdr (assq :readonly cont)))
 875                                'read-only
 876                              'inhibit-read-only)))
 877     (insert value)
 878     (when (< (length value) width)
 879       (insert (make-string (- width (length value)) ? )))
 880     (put-text-property start (point) 'face 'eww-form-text)
 881     (put-text-property start (point) 'inhibit-read-only t)
 882     (put-text-property start (point) 'local-map eww-text-map)
 883     (put-text-property start (point) readonly-property t)
 884     (put-text-property start (point) 'eww-form
 885                        (list :eww-form eww-form
 886                              :value value
 887                              :type type
 888                              :name (cdr (assq :name cont))))
 889     (insert " ")))
 890
 891 (defconst eww-text-input-types '("text" "password" "textarea"
 892                                  "color" "date" "datetime" "datetime-local"
 893                                  "email" "month" "number" "search" "tel"
 894                                  "time" "url" "week")
 895   "List of input types which represent a text input.
 896 See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
 897
 898 (defun eww-process-text-input (beg end length)
 899   (let* ((form (get-text-property (min (1+ end) (point-max)) 'eww-form))
 900          (properties (text-properties-at end))
 901          (type (plist-get form :type)))
 902     (when (and form
 903                (member type eww-text-input-types))
 904       (cond
 905        ((zerop length)
 906         ;; Delete some space at the end.
 907         (save-excursion
 908           (goto-char
 909            (if (equal type "textarea")
 910                (1- (line-end-position))
 911              (eww-end-of-field)))
 912           (let ((new (- end beg)))
 913             (while (and (> new 0)
 914                         (eql (following-char) ? ))
 915               (delete-region (point) (1+ (point)))
 916               (setq new (1- new))))
 917           (set-text-properties beg end properties)))
 918        ((> length 0)
 919         ;; Add padding.
 920         (save-excursion
 921           (goto-char
 922            (if (equal type "textarea")
 923                (1- (line-end-position))
 924              (eww-end-of-field)))
 925           (let ((start (point)))
 926             (insert (make-string length ? ))
 927             (set-text-properties start (point) properties)))))
 928       (let ((value (buffer-substring-no-properties
 929                     (eww-beginning-of-field)
 930                     (eww-end-of-field))))
 931         (when (string-match " +\\'" value)
 932           (setq value (substring value 0 (match-beginning 0))))
 933         (plist-put form :value value)
 934         (when (equal type "password")
 935           ;; Display passwords as asterisks.
 936           (let ((start (eww-beginning-of-field)))
 937             (put-text-property start (+ start (length value))
 938                                'display (make-string (length value) ?*))))))))
 939
 940 (defun eww-tag-textarea (cont)
 941   (let ((start (point))
 942         (value (or (cdr (assq :value cont)) ""))
 943         (lines (string-to-number
 944                 (or (cdr (assq :rows cont))
 945                     "10")))
 946         (width (string-to-number
 947                 (or (cdr (assq :cols cont))
 948                     "10")))
 949         end)
 950     (shr-ensure-newline)
 951     (insert value)
 952     (shr-ensure-newline)
 953     (when (< (count-lines start (point)) lines)
 954       (dotimes (i (- lines (count-lines start (point))))
 955         (insert "\n")))
 956     (setq end (point-marker))
 957     (goto-char start)
 958     (while (< (point) end)
 959       (end-of-line)
 960       (let ((pad (- width (- (point) (line-beginning-position)))))
 961         (when (> pad 0)
 962           (insert (make-string pad ? ))))
 963       (add-face-text-property (line-beginning-position)
 964                               (point) 'eww-form-textarea)
 965       (put-text-property (line-beginning-position) (point) 'inhibit-read-only t)
 966       (put-text-property (line-beginning-position) (point)
 967                          'local-map eww-textarea-map)
 968       (forward-line 1))
 969     (put-text-property start (point) 'eww-form
 970                        (list :eww-form eww-form
 971                              :value value
 972                              :type "textarea"
 973                              :name (cdr (assq :name cont))))))
 974
 975 (defun eww-tag-input (cont)
 976   (let ((type (downcase (or (cdr (assq :type cont))
 977                              "text")))
 978         (start (point)))
 979     (cond
 980      ((or (equal type "checkbox")
 981           (equal type "radio"))
 982       (eww-form-checkbox cont))
 983      ((equal type "file")
 984       (eww-form-file cont))
 985      ((equal type "submit")
 986       (eww-form-submit cont))
 987      ((equal type "hidden")
 988       (let ((form eww-form)
 989             (name (cdr (assq :name cont))))
 990         ;; Don't add <input type=hidden> elements repeatedly.
 991         (while (and form
 992                     (or (not (consp (car form)))
 993                         (not (eq (caar form) 'hidden))
 994                         (not (equal (plist-get (cdr (car form)) :name)
 995                                     name))))
 996           (setq form (cdr form)))
 997         (unless form
 998           (nconc eww-form (list
 999                            (list 'hidden
1000                                  :name name
1001                                  :value (cdr (assq :value cont))))))))
1002      (t
1003       (eww-form-text cont)))
1004     (unless (= start (point))
1005       (put-text-property start (1+ start) 'help-echo "Input field"))))
1006
1007 (defun eww-tag-select (cont)
1008   (shr-ensure-paragraph)
1009   (let ((menu (list :name (cdr (assq :name cont))
1010                     :eww-form eww-form))
1011         (options nil)
1012         (start (point))
1013         (max 0)
1014         opelem)
1015     (if (eq (car (car cont)) 'optgroup)
1016         (dolist (groupelem cont)
1017           (unless (cdr (assq :disabled (cdr groupelem)))
1018             (setq opelem (append opelem (cdr (cdr groupelem))))))
1019       (setq opelem cont))
1020     (dolist (elem opelem)
1021       (when (eq (car elem) 'option)
1022         (when (cdr (assq :selected (cdr elem)))
1023           (nconc menu (list :value
1024                             (cdr (assq :value (cdr elem))))))
1025         (let ((display (or (cdr (assq 'text (cdr elem))) "")))
1026           (setq max (max max (length display)))
1027           (push (list 'item
1028                       :value (cdr (assq :value (cdr elem)))
1029                       :display display)
1030                 options))))
1031     (when options
1032       (setq options (nreverse options))
1033       ;; If we have no selected values, default to the first value.
1034       (unless (plist-get menu :value)
1035         (nconc menu (list :value (nth 2 (car options)))))
1036       (nconc menu options)
1037       (let ((selected (eww-select-display menu)))
1038         (insert selected
1039                 (make-string (- max (length selected)) ? )))
1040       (put-text-property start (point) 'eww-form menu)
1041       (add-face-text-property start (point) 'eww-form-select)
1042       (put-text-property start (point) 'keymap eww-select-map)
1043       (unless (= start (point))
1044        (put-text-property start (1+ start) 'help-echo "select field"))
1045       (shr-ensure-paragraph))))
1046
1047 (defun eww-select-display (select)
1048   (let ((value (plist-get select :value))
1049         display)
1050     (dolist (elem select)
1051       (when (and (consp elem)
1052                  (eq (car elem) 'item)
1053                  (equal value (plist-get (cdr elem) :value)))
1054         (setq display (plist-get (cdr elem) :display))))
1055     display))
1056
1057 (defun eww-change-select ()
1058   "Change the value of the select drop-down menu under point."
1059   (interactive)
1060   (let* ((input (get-text-property (point) 'eww-form))
1061          (completion-ignore-case t)
1062          (options
1063           (delq nil
1064                 (mapcar (lambda (elem)
1065                           (and (consp elem)
1066                                (eq (car elem) 'item)
1067                                (cons (plist-get (cdr elem) :display)
1068                                      (plist-get (cdr elem) :value))))
1069                         input)))
1070          (display
1071           (completing-read "Change value: " options nil 'require-match))
1072          (inhibit-read-only t))
1073     (plist-put input :value (cdr (assoc-string display options t)))
1074     (goto-char
1075      (eww-update-field display))))
1076
1077 (defun eww-update-field (string &optional offset)
1078   (if (not offset) (setq offset 0))
1079   (let ((properties (text-properties-at (point)))
1080         (start (+ (eww-beginning-of-field) offset))
1081         (current-end (1+ (eww-end-of-field)))
1082         (new-end (1+ (+ (eww-beginning-of-field) (length string)))))
1083     (delete-region start current-end)
1084     (forward-char offset)
1085     (insert string
1086             (make-string (- (- (+ new-end offset) start) (length string)) ? ))
1087     (if (= 0 offset) (set-text-properties start new-end properties))
1088     start))
1089
1090 (defun eww-toggle-checkbox ()
1091   "Toggle the value of the checkbox under point."
1092   (interactive)
1093   (let* ((input (get-text-property (point) 'eww-form))
1094          (type (plist-get input :type)))
1095     (if (equal type "checkbox")
1096         (goto-char
1097          (1+
1098           (if (plist-get input :checked)
1099               (progn
1100                 (plist-put input :checked nil)
1101                 (eww-update-field eww-form-checkbox-symbol))
1102             (plist-put input :checked t)
1103             (eww-update-field eww-form-checkbox-selected-symbol))))
1104       ;; Radio button.  Switch all other buttons off.
1105       (let ((name (plist-get input :name)))
1106         (save-excursion
1107           (dolist (elem (eww-inputs (plist-get input :eww-form)))
1108             (when (equal (plist-get (cdr elem) :name) name)
1109               (goto-char (car elem))
1110               (if (not (eq (cdr elem) input))
1111                   (progn
1112                     (plist-put input :checked nil)
1113                     (eww-update-field eww-form-checkbox-symbol))
1114                 (plist-put input :checked t)
1115                 (eww-update-field eww-form-checkbox-selected-symbol)))))
1116         (forward-char 1)))))
1117
1118 (defun eww-inputs (form)
1119   (let ((start (point-min))
1120         (inputs nil))
1121     (while (and start
1122                 (< start (point-max)))
1123       (when (or (get-text-property start 'eww-form)
1124                 (setq start (next-single-property-change start 'eww-form)))
1125         (when (eq (plist-get (get-text-property start 'eww-form) :eww-form)
1126                   form)
1127           (push (cons start (get-text-property start 'eww-form))
1128                 inputs))
1129         (setq start (next-single-property-change start 'eww-form))))
1130     (nreverse inputs)))
1131
1132 (defun eww-input-value (input)
1133   (let ((type (plist-get input :type))
1134         (value (plist-get input :value)))
1135     (cond
1136      ((equal type "textarea")
1137       (with-temp-buffer
1138         (insert value)
1139         (goto-char (point-min))
1140         (while (re-search-forward "^ +\n\\| +$" nil t)
1141           (replace-match "" t t))
1142         (buffer-string)))
1143      (t
1144       (if (string-match " +\\'" value)
1145           (substring value 0 (match-beginning 0))
1146         value)))))
1147
1148 (defun eww-submit ()
1149   "Submit the current form."
1150   (interactive)
1151   (let* ((this-input (get-text-property (point) 'eww-form))
1152          (form (plist-get this-input :eww-form))
1153          values next-submit)
1154     (dolist (elem (sort (eww-inputs form)
1155                         (lambda (o1 o2)
1156                           (< (car o1) (car o2)))))
1157       (let* ((input (cdr elem))
1158              (input-start (car elem))
1159              (name (plist-get input :name)))
1160         (when name
1161           (cond
1162            ((member (plist-get input :type) '("checkbox" "radio"))
1163             (when (plist-get input :checked)
1164               (push (cons name (plist-get input :value))
1165                     values)))
1166            ((equal (plist-get input :type) "file")
1167             (push (cons "file"
1168                         (list (cons "filedata"
1169                                     (with-temp-buffer
1170                                       (insert-file-contents
1171                                        (plist-get input :filename))
1172                                       (buffer-string)))
1173                               (cons "name" (plist-get input :name))
1174                               (cons "filename" (plist-get input :filename))))
1175                   values))
1176            ((equal (plist-get input :type) "submit")
1177             ;; We want the values from buttons if we hit a button if
1178             ;; we hit enter on it, or if it's the first button after
1179             ;; the field we did hit return on.
1180             (when (or (eq input this-input)
1181                       (and (not (eq input this-input))
1182                            (null next-submit)
1183                            (> input-start (point))))
1184               (setq next-submit t)
1185               (push (cons name (plist-get input :value))
1186                     values)))
1187            (t
1188             (push (cons name (eww-input-value input))
1189                   values))))))
1190     (dolist (elem form)
1191       (when (and (consp elem)
1192                  (eq (car elem) 'hidden))
1193         (push (cons (plist-get (cdr elem) :name)
1194                     (or (plist-get (cdr elem) :value) ""))
1195               values)))
1196     (if (and (stringp (cdr (assq :method form)))
1197              (equal (downcase (cdr (assq :method form))) "post"))
1198         (let ((mtype))
1199           (dolist (x values mtype)
1200             (if (equal (car x) "file")
1201                 (progn
1202                   (setq mtype "multipart/form-data"))))
1203           (cond ((equal mtype "multipart/form-data")
1204                  (let ((boundary (mml-compute-boundary '())))
1205                    (let ((url-request-method "POST")
1206                          (url-request-extra-headers
1207                           (list (cons "Content-Type"
1208                                       (concat "multipart/form-data; boundary="
1209                                               boundary))))
1210                          (url-request-data
1211                           (mm-url-encode-multipart-form-data values boundary)))
1212                      (eww-browse-url (shr-expand-url
1213                                       (cdr (assq :action form))
1214                                       (plist-get eww-data :url))))))
1215                 (t
1216                  (let ((url-request-method "POST")
1217                        (url-request-extra-headers
1218                         '(("Content-Type" .
1219                            "application/x-www-form-urlencoded")))
1220                        (url-request-data
1221                         (mm-url-encode-www-form-urlencoded values)))
1222                    (eww-browse-url (shr-expand-url
1223                                     (cdr (assq :action form))
1224                                     (plist-get eww-data :url)))))))
1225       (eww-browse-url
1226        (concat
1227         (if (cdr (assq :action form))
1228             (shr-expand-url (cdr (assq :action form))
1229                             (plist-get eww-data :url))
1230           (plist-get eww-data :url))
1231         "?"
1232         (mm-url-encode-www-form-urlencoded values))))))
1233
1234 (defun eww-browse-with-external-browser (&optional url)
1235   "Browse the current URL with an external browser.
1236 The browser to used is specified by the `shr-external-browser' variable."
1237   (interactive)
1238   (funcall shr-external-browser (or url (plist-get eww-data :url))))
1239
1240 (defun eww-follow-link (&optional external mouse-event)
1241   "Browse the URL under point.
1242 If EXTERNAL, browse the URL using `shr-external-browser'."
1243   (interactive (list current-prefix-arg last-nonmenu-event))
1244   (mouse-set-point mouse-event)
1245   (let ((url (get-text-property (point) 'shr-url)))
1246     (cond
1247      ((not url)
1248       (message "No link under point"))
1249      ((string-match "^mailto:" url)
1250       (browse-url-mail url))
1251      (external
1252       (funcall shr-external-browser url))
1253      ;; This is a #target url in the same page as the current one.
1254      ((and (url-target (url-generic-parse-url url))
1255            (eww-same-page-p url (plist-get eww-data :url)))
1256       (eww-save-history)
1257       (eww-display-html 'utf-8 url (plist-get eww-data :url)
1258                         nil (current-buffer)))
1259      (t
1260       (eww-browse-url url)))))
1261
1262 (defun eww-same-page-p (url1 url2)
1263   "Return non-nil if both URLs represent the same page.
1264 Differences in #targets are ignored."
1265   (let ((obj1 (url-generic-parse-url url1))
1266         (obj2 (url-generic-parse-url url2)))
1267     (setf (url-target obj1) nil)
1268     (setf (url-target obj2) nil)
1269     (equal (url-recreate-url obj1) (url-recreate-url obj2))))
1270
1271 (defun eww-copy-page-url ()
1272   (interactive)
1273   (message "%s" (plist-get eww-data :url))
1274   (kill-new (plist-get eww-data :url)))
1275
1276 (defun eww-download ()
1277   "Download URL under point to `eww-download-directory'."
1278   (interactive)
1279   (let ((url (get-text-property (point) 'shr-url)))
1280     (if (not url)
1281         (message "No URL under point")
1282       (url-retrieve url 'eww-download-callback (list url)))))
1283
1284 (defun eww-download-callback (status url)
1285   (unless (plist-get status :error)
1286     (let* ((obj (url-generic-parse-url url))
1287            (path (car (url-path-and-query obj)))
1288            (file (eww-make-unique-file-name (file-name-nondirectory path)
1289                                             eww-download-directory)))
1290       (goto-char (point-min))
1291       (re-search-forward "\r?\n\r?\n")
1292       (write-region (point) (point-max) file)
1293       (message "Saved %s" file))))
1294
1295 (defun eww-make-unique-file-name (file directory)
1296     (cond
1297      ((zerop (length file))
1298       (setq file "!"))
1299      ((string-match "\\`[.]" file)
1300       (setq file (concat "!" file))))
1301     (let ((count 1))
1302       (while (file-exists-p (expand-file-name file directory))
1303         (setq file
1304               (if (string-match "\\`\\(.*\\)\\([.][^.]+\\)" file)
1305                   (format "%s(%d)%s" (match-string 1 file)
1306                           count (match-string 2 file))
1307                 (format "%s(%d)" file count)))
1308         (setq count (1+ count)))
1309       (expand-file-name file directory)))
1310
1311 ;;; Bookmarks code
1312
1313 (defvar eww-bookmarks nil)
1314
1315 (defun eww-add-bookmark ()
1316   "Add the current page to the bookmarks."
1317   (interactive)
1318   (eww-read-bookmarks)
1319   (dolist (bookmark eww-bookmarks)
1320     (when (equal (plist-get eww-data :url) (plist-get bookmark :url))
1321       (user-error "Already bookmarked")))
1322   (if (y-or-n-p "bookmark this page? ")
1323       (progn
1324         (let ((title (replace-regexp-in-string "[\n\t\r]" " "
1325                                                (plist-get eww-data :url))))
1326           (setq title (replace-regexp-in-string "\\` +\\| +\\'" "" title))
1327           (push (list :url (plist-get eww-data :url)
1328                       :title title
1329                       :time (current-time-string))
1330                 eww-bookmarks))
1331         (eww-write-bookmarks)
1332         (message "Bookmarked %s (%s)" (plist-get eww-data :url)
1333                  (plist-get eww-data :title)))))
1334
1335 (defun eww-write-bookmarks ()
1336   (with-temp-file (expand-file-name "eww-bookmarks" eww-bookmarks-directory)
1337     (insert ";; Auto-generated file; don't edit\n")
1338     (pp eww-bookmarks (current-buffer))))
1339
1340 (defun eww-read-bookmarks ()
1341   (let ((file (expand-file-name "eww-bookmarks" eww-bookmarks-directory)))
1342     (setq eww-bookmarks
1343           (unless (zerop (or (nth 7 (file-attributes file)) 0))
1344             (with-temp-buffer
1345               (insert-file-contents file)
1346               (read (current-buffer)))))))
1347
1348 ;;;###autoload
1349 (defun eww-list-bookmarks ()
1350   "Display the bookmarks."
1351   (interactive)
1352   (eww-bookmark-prepare)
1353   (pop-to-buffer "*eww bookmarks*"))
1354
1355 (defun eww-bookmark-prepare ()
1356   (eww-read-bookmarks)
1357   (unless eww-bookmarks
1358     (user-error "No bookmarks are defined"))
1359   (set-buffer (get-buffer-create "*eww bookmarks*"))
1360   (eww-bookmark-mode)
1361   (let ((format "%-40s %s")
1362         (inhibit-read-only t)
1363         start url)
1364     (erase-buffer)
1365     (setq header-line-format (concat " " (format format "URL" "Title")))
1366     (dolist (bookmark eww-bookmarks)
1367       (setq start (point))
1368       (setq url (plist-get bookmark :url))
1369       (when (> (length url) 40)
1370         (setq url (substring url 0 40)))
1371       (insert (format format url
1372                       (plist-get bookmark :title))
1373               "\n")
1374       (put-text-property start (1+ start) 'eww-bookmark bookmark))
1375     (goto-char (point-min))))
1376
1377 (defvar eww-bookmark-kill-ring nil)
1378
1379 (defun eww-bookmark-kill ()
1380   "Kill the current bookmark."
1381   (interactive)
1382   (let* ((start (line-beginning-position))
1383          (bookmark (get-text-property start 'eww-bookmark))
1384          (inhibit-read-only t))
1385     (unless bookmark
1386       (user-error "No bookmark on the current line"))
1387     (forward-line 1)
1388     (push (buffer-substring start (point)) eww-bookmark-kill-ring)
1389     (delete-region start (point))
1390     (setq eww-bookmarks (delq bookmark eww-bookmarks))
1391     (eww-write-bookmarks)))
1392
1393 (defun eww-bookmark-yank ()
1394   "Yank a previously killed bookmark to the current line."
1395   (interactive)
1396   (unless eww-bookmark-kill-ring
1397     (user-error "No previously killed bookmark"))
1398   (beginning-of-line)
1399   (let ((inhibit-read-only t)
1400         (start (point))
1401         bookmark)
1402     (insert (pop eww-bookmark-kill-ring))
1403     (setq bookmark (get-text-property start 'eww-bookmark))
1404     (if (= start (point-min))
1405         (push bookmark eww-bookmarks)
1406       (let ((line (count-lines start (point))))
1407         (setcdr (nthcdr (1- line) eww-bookmarks)
1408                 (cons bookmark (nthcdr line eww-bookmarks)))))
1409     (eww-write-bookmarks)))
1410
1411 (defun eww-bookmark-browse ()
1412   "Browse the bookmark under point in eww."
1413   (interactive)
1414   (let ((bookmark (get-text-property (line-beginning-position) 'eww-bookmark)))
1415     (unless bookmark
1416       (user-error "No bookmark on the current line"))
1417     (quit-window)
1418     (eww-browse-url (plist-get bookmark :url))))
1419
1420 (defun eww-next-bookmark ()
1421   "Go to the next bookmark in the list."
1422   (interactive)
1423   (let ((first nil)
1424         bookmark)
1425     (unless (get-buffer "*eww bookmarks*")
1426       (setq first t)
1427       (eww-bookmark-prepare))
1428     (with-current-buffer (get-buffer "*eww bookmarks*")
1429       (when (and (not first)
1430                  (not (eobp)))
1431         (forward-line 1))
1432       (setq bookmark (get-text-property (line-beginning-position)
1433                                         'eww-bookmark))
1434       (unless bookmark
1435         (user-error "No next bookmark")))
1436     (eww-browse-url (plist-get bookmark :url))))
1437
1438 (defun eww-previous-bookmark ()
1439   "Go to the previous bookmark in the list."
1440   (interactive)
1441   (let ((first nil)
1442         bookmark)
1443     (unless (get-buffer "*eww bookmarks*")
1444       (setq first t)
1445       (eww-bookmark-prepare))
1446     (with-current-buffer (get-buffer "*eww bookmarks*")
1447       (if first
1448           (goto-char (point-max))
1449         (beginning-of-line))
1450       ;; On the final line.
1451       (when (eolp)
1452         (forward-line -1))
1453       (if (bobp)
1454           (user-error "No previous bookmark")
1455         (forward-line -1))
1456       (setq bookmark (get-text-property (line-beginning-position)
1457                                         'eww-bookmark)))
1458     (eww-browse-url (plist-get bookmark :url))))
1459
1460 (defvar eww-bookmark-mode-map
1461   (let ((map (make-sparse-keymap)))
1462     (suppress-keymap map)
1463     (define-key map "q" 'quit-window)
1464     (define-key map [(control k)] 'eww-bookmark-kill)
1465     (define-key map [(control y)] 'eww-bookmark-yank)
1466     (define-key map "\r" 'eww-bookmark-browse)
1467
1468     (easy-menu-define nil map
1469       "Menu for `eww-bookmark-mode-map'."
1470       '("Eww Bookmark"
1471         ["Exit" quit-window t]
1472         ["Browse" eww-bookmark-browse
1473          :active (get-text-property (line-beginning-position) 'eww-bookmark)]
1474         ["Kill" eww-bookmark-kill
1475          :active (get-text-property (line-beginning-position) 'eww-bookmark)]
1476         ["Yank" eww-bookmark-yank
1477          :active eww-bookmark-kill-ring]))
1478     map))
1479
1480 (define-derived-mode eww-bookmark-mode nil "eww bookmarks"
1481   "Mode for listing bookmarks.
1482
1483 \\{eww-bookmark-mode-map}"
1484   (buffer-disable-undo)
1485   (setq buffer-read-only t
1486         truncate-lines t))
1487
1488 ;;; History code
1489
1490 (defun eww-save-history ()
1491   (plist-put eww-data :point (point))
1492   (plist-put eww-data :text (buffer-string))
1493   (push eww-data eww-history)
1494   (setq eww-data (list :title ""))
1495   ;; Don't let the history grow infinitely.  We store quite a lot of
1496   ;; data per page.
1497   (when-let (tail (and eww-history-limit
1498                        (nthcdr eww-history-limit eww-history)))
1499     (setcdr tail nil)))
1500
1501 (defun eww-list-histories ()
1502   "List the eww-histories."
1503   (interactive)
1504   (when (null eww-history)
1505     (error "No eww-histories are defined"))
1506   (let ((eww-history-trans eww-history))
1507     (set-buffer (get-buffer-create "*eww history*"))
1508     (eww-history-mode)
1509     (let ((inhibit-read-only t)
1510           (domain-length 0)
1511           (title-length 0)
1512           url title format start)
1513       (erase-buffer)
1514       (dolist (history eww-history-trans)
1515         (setq start (point))
1516         (setq domain-length (max domain-length (length (plist-get history :url))))
1517         (setq title-length (max title-length (length (plist-get history :title)))))
1518       (setq format (format "%%-%ds %%-%ds" title-length domain-length)
1519             header-line-format
1520             (concat " " (format format "Title" "URL")))
1521       (dolist (history eww-history-trans)
1522         (setq start (point))
1523         (setq url (plist-get history :url))
1524         (setq title (plist-get history :title))
1525         (insert (format format title url))
1526         (insert "\n")
1527         (put-text-property start (1+ start) 'eww-history history))
1528       (goto-char (point-min)))
1529     (pop-to-buffer "*eww history*")))
1530
1531 (defun eww-history-browse ()
1532   "Browse the history under point in eww."
1533   (interactive)
1534   (let ((history (get-text-property (line-beginning-position) 'eww-history)))
1535     (unless history
1536       (error "No history on the current line"))
1537     (quit-window)
1538     (eww-restore-history history)))
1539
1540 (defvar eww-history-mode-map
1541   (let ((map (make-sparse-keymap)))
1542     (suppress-keymap map)
1543     (define-key map "q" 'quit-window)
1544     (define-key map "\r" 'eww-history-browse)
1545 ;;    (define-key map "n" 'next-error-no-select)
1546 ;;    (define-key map "p" 'previous-error-no-select)
1547
1548     (easy-menu-define nil map
1549       "Menu for `eww-history-mode-map'."
1550       '("Eww History"
1551         ["Exit" quit-window t]
1552         ["Browse" eww-history-browse
1553          :active (get-text-property (line-beginning-position) 'eww-history)]))
1554     map))
1555
1556 (define-derived-mode eww-history-mode nil "eww history"
1557   "Mode for listing eww-histories.
1558
1559 \\{eww-history-mode-map}"
1560   (buffer-disable-undo)
1561   (setq buffer-read-only t
1562         truncate-lines t))
1563
1564 ;;; Desktop support
1565
1566 (defvar eww-desktop-data-save
1567   '(:url :title :point)
1568   "List of `eww-data' properties to preserve in the desktop file.
1569 Also used when saving `eww-history'.")
1570
1571 (defun eww-desktop-data-1 (alist)
1572   (let ((acc  nil)
1573         (tail alist))
1574     (while tail
1575       (let ((k (car  tail))
1576             (v (cadr tail)))
1577         (when (memq k eww-desktop-data-save)
1578           (setq acc (cons k (cons v acc)))))
1579       (setq tail  (cddr tail)))
1580     acc))
1581
1582 (defun eww-desktop-history-duplicate (a b)
1583   (let ((tail a) (r t))
1584     (while tail
1585       (if (or (memq (car tail) '(:point)) ; ignore :point
1586               (equal (cadr tail)
1587                      (plist-get b (car tail))))
1588           (setq tail (cddr tail))
1589         (setq tail nil
1590               r    nil)))
1591     ;; .
1592     r))
1593
1594 (defun eww-desktop-misc-data (directory)
1595   "Return a property list with data used to restore eww buffers.
1596 This list will contain, as :history, the list, whose first element is
1597 the value of `eww-data', and the tail is `eww-history'.
1598
1599 If `eww-desktop-remove-duplicates' is non-nil, duplicate
1600 entries (if any) will be removed from the list.
1601
1602 Only the properties listed in `eww-desktop-data-save' are included.
1603 Generally, the list should not include the (usually overly large)
1604 :dom, :source and :text properties."
1605   (let ((history  (mapcar 'eww-desktop-data-1
1606                           (cons eww-data eww-history))))
1607     (list :history  (if eww-desktop-remove-duplicates
1608                         (cl-remove-duplicates
1609                          history :test 'eww-desktop-history-duplicate)
1610                       history))))
1611
1612 (defun eww-restore-desktop (file-name buffer-name misc-data)
1613   "Restore an eww buffer from its desktop file record.
1614 If `eww-restore-desktop' is t or 'auto, this function will also
1615 initiate the retrieval of the respective URI in the background.
1616 Otherwise, the restored buffer will contain a prompt to do so by using
1617 \\[eww-reload]."
1618   (with-current-buffer (get-buffer-create buffer-name)
1619     (eww-mode)
1620     ;; NB: eww-history, eww-data are buffer-local per (eww-mode)
1621     (setq eww-history       (cdr (plist-get misc-data :history))
1622           eww-data      (or (car (plist-get misc-data :history))
1623                             ;; backwards compatibility
1624                             (list :url (plist-get misc-data :uri))))
1625     (unless file-name
1626       (when (plist-get eww-data :url)
1627         (case eww-restore-desktop
1628           ((t auto) (eww (plist-get eww-data :url)))
1629           ((zerop (buffer-size))
1630            (insert (substitute-command-keys
1631                     eww-restore-reload-prompt))))))
1632     ;; .
1633     (current-buffer)))
1634
1635 (add-to-list 'desktop-locals-to-save
1636              'eww-history-position)
1637 (add-to-list 'desktop-buffer-mode-handlers
1638              '(eww-mode . eww-restore-desktop))
1639
1640 (provide 'eww)
1641
1642 ;;; eww.el ends here