diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/gnus/ChangeLog | 55 | ||||
| -rw-r--r-- | lisp/gnus/eww.el | 121 | ||||
| -rw-r--r-- | lisp/gnus/shr.el | 177 |
3 files changed, 270 insertions, 83 deletions
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 33ae989d15..58b5ae1a56 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,58 @@ +2013-06-16 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * eww.el (eww-display-html): Default to using the entire window width. + + * shr.el (shr-make-table): Cache the table rendering at the table + level, and not the <td> level. This is a bit faster. + + * eww.el (eww-render): Go to the correct ID when given URLs ending with + #id. + + * shr.el (shr-tag-li): Don't require a new paragraph, since other + browsers don't. + (shr-expand-url): Respect #anchor links. + (shr-parse-base): Chop off the anchor before using. + (shr-descend): Respect display: none. + (shr-descend): Allow marking elements that have certain IDs. + + * eww.el (eww-tag-textarea): Use `text' instead of `editable-field'. + + * shr.el (shr-expand-url): Don't bug out on zero-length links. + + * eww.el (eww-tag-textarea): Support <textarea>. + +2013-06-16 Rüdiger Sonderfeld <ruediger@c-plusplus.de> + + * shr.el (shr-dom-to-xml): Fixed function call. + + * eww.el (eww): New group. + (eww-header-line-format): New custom variable. + (eww-current-title): New variable. + (eww-display-html): Update header and handle title tag. + (eww-update-header-line-format): New function. + (eww-tag-title): New function. + + * shr.el (shr-dom-to-xml): (shr-dom-to-xml): New function. + (shr-tag-svg): Add support for the SVG tag. + (shr-bullet): New custom variable. + (shr-tag-li): Support custom bullet in unordered lists. + +2013-06-16 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * shr.el (shr-expand-url): Respect // URLs. + + * eww.el (eww-tag-body): Override the shr body rendering so that we can + put a background colour onto the entire buffer. + (eww-render): When being redirected, use the redirect URL as the new + base URL. + + * shr.el (shr-parse-base): Fix parsing error. + + * eww.el (eww-submit): Pass the base in to `shr-expand-url'. + + * shr.el (shr-parse-base): New function. + (shr-expand-url): Use it to expand relative URLs reliably. + 2013-06-15 Teodor Zlatanov <tzz@lifelogs.com> * auth-source.el (auth-source-search-collection): Fix docstring. diff --git a/lisp/gnus/eww.el b/lisp/gnus/eww.el index 270c3ee3ed..b34ec7655c 100644 --- a/lisp/gnus/eww.el +++ b/lisp/gnus/eww.el @@ -29,7 +29,22 @@ (require 'url) (require 'mm-url) +(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." + :group 'eww + :type 'string) + (defvar eww-current-url nil) +(defvar eww-current-title "" + "Title of current page.") (defvar eww-history nil) ;;;###autoload @@ -53,7 +68,13 @@ (match-string 1))))) (defun eww-render (status url &optional point) + (let ((redirect (plist-get status :redirect))) + (when redirect + (setq url redirect))) (let* ((headers (eww-parse-headers)) + (shr-target-id + (and (string-match "#\\(.*\\)" url) + (match-string 1 url))) (content-type (mail-header-parse-content-type (or (cdr (assoc "content-type" headers)) @@ -74,8 +95,14 @@ (eww-display-image)) (t (eww-display-raw charset))) - (when point - (goto-char point))) + (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))))))) (kill-buffer data-buffer)))) (defun eww-parse-headers () @@ -101,15 +128,56 @@ (libxml-parse-html-region (point) (point-max))))) (eww-setup-buffer) (setq eww-current-url url) + (eww-update-header-line-format) (let ((inhibit-read-only t) + (shr-width nil) (shr-external-rendering-functions - '((form . eww-tag-form) + '((title . eww-tag-title) + (form . eww-tag-form) (input . eww-tag-input) + (textarea . eww-tag-textarea) + (body . eww-tag-body) (select . eww-tag-select)))) (shr-insert-document document) (eww-convert-widgets)) (goto-char (point-min)))) +(defun eww-update-header-line-format () + (if eww-header-line-format + (setq header-line-format (format-spec eww-header-line-format + `((?u . ,eww-current-url) + (?t . ,eww-current-title)))) + (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 + (eww-put-color start end :foreground (cadr new-colors))) + (when bg + (eww-put-color start end :background (car new-colors))))))) + +(defun eww-put-color (start end type color) + (shr-put-color-1 start end type color)) + (defun eww-display-raw (charset) (let ((data (buffer-substring (point) (point-max)))) (eww-setup-buffer) @@ -240,6 +308,21 @@ (apply 'widget-create widget) (put-text-property start (point) 'eww-widget widget)))) +(defun eww-tag-textarea (cont) + (let* ((start (point)) + (widget + (list 'text + :size (string-to-number + (or (cdr (assq :cols cont)) + "40")) + :value (or (cdr (assq 'text cont)) "") + :action 'eww-submit + :name (cdr (assq :name cont)) + :eww-form eww-form))) + (nconc eww-form (list widget)) + (apply 'widget-create widget) + (put-text-property start (point) 'eww-widget widget))) + (defun eww-tag-select (cont) (shr-ensure-paragraph) (let ((menu (list 'menu-choice @@ -330,22 +413,22 @@ (plist-get (cdr elem) :value)) values) (setq rest nil)))))) - (debug values) - (let ((shr-base eww-current-url)) - (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-browse-url - (concat - (if (cdr (assq :action form)) - (shr-expand-url (cdr (assq :action form))) - eww-current-url) - "?" - (mm-url-encode-www-form-urlencoded values))))))) + (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)))))) (defun eww-convert-widgets () (let ((start (point-min)) diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el index c93357efd2..339b969892 100644 --- a/lisp/gnus/shr.el +++ b/lisp/gnus/shr.el @@ -83,6 +83,14 @@ used." (const :tag "Use the width of the window" nil)) :group 'shr) +(defcustom shr-bullet "* " + "Bullet used for unordered lists. +Alternative suggestions are: +- \" \" +- \" \"" + :type 'string + :group 'shr) + (defvar shr-content-function nil "If bound, this should be a function that will return the content. This is used for cid: URLs, and the function is called with the @@ -115,6 +123,7 @@ cid: URL as the argument.") (defvar shr-base nil) (defvar shr-ignore-cache nil) (defvar shr-external-rendering-functions nil) +(defvar shr-target-id nil) (defvar shr-map (let ((map (make-sparse-keymap))) @@ -303,18 +312,24 @@ size, and full-buffer size." (shr-stylesheet shr-stylesheet) (start (point))) (when style - (if (string-match "color" style) + (if (string-match "color\\|display" style) (setq shr-stylesheet (nconc (shr-parse-style style) shr-stylesheet)) (setq style nil))) - (if (fboundp function) - (funcall function (cdr dom)) - (shr-generic (cdr dom))) - ;; If style is set, then this node has set the color. - (when style - (shr-colorize-region start (point) - (cdr (assq 'color shr-stylesheet)) - (cdr (assq 'background-color shr-stylesheet)))))) + ;; If we have a display:none, then just ignore this part of the + ;; DOM. + (unless (equal (cdr (assq 'display shr-stylesheet)) "none") + (if (fboundp function) + (funcall function (cdr dom)) + (shr-generic (cdr dom))) + (when (and shr-target-id + (equal (cdr (assq :id (cdr dom))) shr-target-id)) + (put-text-property start (1+ start) 'shr-target-id shr-target-id)) + ;; If style is set, then this node has set the color. + (when style + (shr-colorize-region start (point) + (cdr (assq 'color shr-stylesheet)) + (cdr (assq 'background-color shr-stylesheet))))))) (defun shr-generic (cont) (dolist (sub cont) @@ -484,31 +499,51 @@ size, and full-buffer size." (forward-char 1)))) (not failed))) -(defun shr-expand-url (url) - (if (or (not url) - (string-match "\\`[a-z]*:" url) - (not shr-base)) - ;; Absolute URL. - url - (let ((base shr-base)) - ;; Chop off query string. - (when (string-match "\\`\\([^?]+\\)[?]" base) - (setq base (match-string 1 base))) - ;; Chop off the bit after the last slash. - (when (string-match "\\`\\(.*\\)[/][^/]+" base) - (setq base (match-string 1 base))) - (cond - ((and (string-match "\\`//" url) - (string-match "\\`[a-z]*:" base)) - (concat (match-string 0 base) url)) - ((and (not (string-match "/\\'" base)) - (not (string-match "\\`/" url))) - (concat base "/" url)) - ((and (string-match "\\`/" url) - (string-match "\\(\\`[^:]*://[^/]+\\)/" base)) - (concat (match-string 1 base) url)) - (t - (concat base url)))))) +(defun shr-parse-base (url) + ;; Always chop off anchors. + (when (string-match "#.*" url) + (setq url (substring url 0 (match-beginning 0)))) + (let* ((parsed (url-generic-parse-url url)) + (local (url-filename parsed))) + (setf (url-filename parsed) "") + ;; Chop off the bit after the last slash. + (when (string-match "\\`\\(.*/\\)[^/]+\\'" local) + (setq local (match-string 1 local))) + ;; Always make the local bit end with a slash. + (when (and (not (zerop (length local))) + (not (eq (aref local (1- (length local))) ?/))) + (setq local (concat local "/"))) + (list (url-recreate-url parsed) + local + (url-type parsed) + url))) + +(defun shr-expand-url (url &optional base) + (setq base + (if base + (shr-parse-base base) + ;; Bound by the parser. + shr-base)) + (when (zerop (length url)) + (setq url nil)) + (cond ((or (not url) + (not base) + (string-match "\\`[a-z]*:" url)) + ;; Absolute URL. + (or url (car base))) + ((eq (aref url 0) ?/) + (if (and (> (length url) 1) + (eq (aref url 1) ?/)) + ;; //host...; just use the protocol + (concat (nth 2 base) ":" url) + ;; Just use the host name part. + (concat (car base) url))) + ((eq (aref url 0) ?#) + ;; A link to an anchor. + (concat (nth 3 base) url)) + (t + ;; Totally relative. + (concat (car base) (cadr base) url)))) (defun shr-ensure-newline () (unless (zerop (current-column)) @@ -894,8 +929,31 @@ ones, in case fg and bg are nil." (defun shr-tag-comment (cont) ) +(defun shr-dom-to-xml (dom) + "Convert DOM into a string containing the xml representation." + (let ((arg " ") + (text "")) + (dolist (sub (cdr dom)) + (cond + ((listp (cdr sub)) + (setq text (concat text (shr-dom-to-xml sub)))) + ((eq (car sub) 'text) + (setq text (concat text (cdr sub)))) + (t + (setq arg (concat arg (format "%s=\"%s\" " + (substring (symbol-name (car sub)) 1) + (cdr sub))))))) + (format "<%s%s>%s</%s>" + (car dom) + (substring arg 0 (1- (length arg))) + text + (car dom)))) + (defun shr-tag-svg (cont) - ) + (when (image-type-available-p 'svg) + (funcall shr-put-image-function + (shr-dom-to-xml (cons 'svg cont)) + "SVG Image"))) (defun shr-tag-sup (cont) (let ((start (point))) @@ -965,7 +1023,7 @@ ones, in case fg and bg are nil." plist))) (defun shr-tag-base (cont) - (setq shr-base (cdr (assq :href cont))) + (setq shr-base (shr-parse-base (cdr (assq :href cont)))) (shr-generic cont)) (defun shr-tag-a (cont) @@ -1087,14 +1145,14 @@ ones, in case fg and bg are nil." (shr-ensure-paragraph)) (defun shr-tag-li (cont) - (shr-ensure-paragraph) + (shr-ensure-newline) (shr-indent) (let* ((bullet (if (numberp shr-list-mode) (prog1 (format "%d " shr-list-mode) (setq shr-list-mode (1+ shr-list-mode))) - "* ")) + shr-bullet)) (shr-indentation (+ shr-indentation (length bullet)))) (insert bullet) (shr-generic cont))) @@ -1352,6 +1410,13 @@ ones, in case fg and bg are nil." widths)) (defun shr-make-table (cont widths &optional fill) + (or (cadr (assoc (list cont widths fill) shr-content-cache)) + (let ((data (shr-make-table-1 cont widths fill))) + (push (list (list cont widths fill) data) + shr-content-cache) + data))) + +(defun shr-make-table-1 (cont widths &optional fill) (let ((trs nil)) (dolist (row cont) (when (eq (car row) 'tr) @@ -1385,32 +1450,16 @@ ones, in case fg and bg are nil." (setq style (nconc (list (cons 'color fgcolor)) style))) (when style (setq shr-stylesheet (append style shr-stylesheet))) - (let ((cache (cdr (assoc (cons width cont) shr-content-cache)))) - (if cache - (progn - (insert (car cache)) - (let ((end (length (car cache)))) - (dolist (overlay (cadr cache)) - (let ((new-overlay - (shr-make-overlay (1+ (- end (nth 0 overlay))) - (1+ (- end (nth 1 overlay))))) - (properties (nth 2 overlay))) - (while properties - (overlay-put new-overlay - (pop properties) (pop properties))))))) - (let ((shr-width width) - (shr-indentation 0)) - (shr-descend (cons 'td cont))) - ;; Delete padding at the bottom of the TDs. - (delete-region - (point) - (progn - (skip-chars-backward " \t\n") - (end-of-line) - (point))) - (push (list (cons width cont) (buffer-string) - (shr-overlays-in-region (point-min) (point-max))) - shr-content-cache))) + (let ((shr-width width) + (shr-indentation 0)) + (shr-descend (cons 'td cont))) + ;; Delete padding at the bottom of the TDs. + (delete-region + (point) + (progn + (skip-chars-backward " \t\n") + (end-of-line) + (point))) (goto-char (point-min)) (let ((max 0)) (while (not (eobp)) |