diff options
Diffstat (limited to 'lisp/gnus/shr.el')
| -rw-r--r-- | lisp/gnus/shr.el | 177 |
1 files changed, 113 insertions, 64 deletions
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)) |