X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fshr.el;h=06abde9e38160e07d8b0fc527063522ed6656daf;hb=b6cfb4b5425506ac4d2f8b919296d4cb7c46943e;hp=ff8c918b7e8e96d2e92077d564169233a593cdf1;hpb=c51a478e5206246505408b920b26fd998cd2bb7c;p=gnus diff --git a/lisp/shr.el b/lisp/shr.el index ff8c918b7..06abde9e3 100644 --- a/lisp/shr.el +++ b/lisp/shr.el @@ -125,6 +125,7 @@ cid: URL as the argument.") (defvar shr-ignore-cache nil) (defvar shr-external-rendering-functions nil) (defvar shr-target-id nil) +(defvar shr-inhibit-decoration nil) (defvar shr-map (let ((map (make-sparse-keymap))) @@ -141,10 +142,14 @@ cid: URL as the argument.") map)) ;; Public functions and commands. +(declare-function libxml-parse-html-region "xml.c" + (start end &optional base-url)) (defun shr-render-buffer (buffer) "Display the HTML rendering of the current buffer." (interactive (list (current-buffer))) + (or (fboundp 'libxml-parse-html-region) + (error "This function requires Emacs to be compiled with libxml2")) (pop-to-buffer "*html*") (erase-buffer) (shr-insert-document @@ -222,9 +227,9 @@ redirects somewhere else." (defun shr-next-link () "Skip to the next link." (interactive) - (let ((skip (text-property-any (point) (point-max) 'shr-url nil))) + (let ((skip (text-property-any (point) (point-max) 'help-echo nil))) (if (not (setq skip (text-property-not-all skip (point-max) - 'shr-url nil))) + 'help-echo nil))) (message "No next link") (goto-char skip) (message "%s" (get-text-property (point) 'help-echo))))) @@ -236,11 +241,11 @@ redirects somewhere else." (found nil)) ;; Skip past the current link. (while (and (not (bobp)) - (get-text-property (point) 'shr-url)) + (get-text-property (point) 'help-echo)) (forward-char -1)) ;; Find the previous link. (while (and (not (bobp)) - (not (setq found (get-text-property (point) 'shr-url)))) + (not (setq found (get-text-property (point) 'help-echo)))) (forward-char -1)) (if (not found) (progn @@ -248,7 +253,7 @@ redirects somewhere else." (goto-char start)) ;; Put point at the start of the link. (while (and (not (bobp)) - (get-text-property (point) 'shr-url)) + (get-text-property (point) 'help-echo)) (forward-char -1)) (forward-char 1) (message "%s" (get-text-property (point) 'help-echo))))) @@ -349,7 +354,7 @@ size, and full-buffer size." (shr-stylesheet shr-stylesheet) (start (point))) (when style - (if (string-match "color\\|display" style) + (if (string-match "color\\|display\\|border-collapse" style) (setq shr-stylesheet (nconc (shr-parse-style style) shr-stylesheet)) (setq style nil))) @@ -595,7 +600,14 @@ size, and full-buffer size." (insert "\n")) (if (save-excursion (beginning-of-line) - (looking-at " *$")) + ;; If the current line is totally blank, and doesn't even + ;; have any face properties set, then delete the blank + ;; space. + (and (looking-at " *$") + (not (get-text-property (point) 'face)) + (not (= (next-single-property-change (point) 'face nil + (line-end-position)) + (line-end-position))))) (delete-region (match-beginning 0) (match-end 0)) (insert "\n\n"))))) @@ -609,24 +621,20 @@ size, and full-buffer size." (dolist (type types) (shr-add-font (or shr-start (point)) (point) type)))) -(defun shr-make-overlay (beg end &optional buffer front-advance rear-advance) - (let ((overlay (make-overlay beg end buffer front-advance rear-advance))) - (overlay-put overlay 'evaporate t) - overlay)) - ;; Add face to the region, but avoid putting the font properties on ;; blank text at the start of the line, and the newline at the end, to ;; avoid ugliness. (defun shr-add-font (start end type) - (save-excursion - (goto-char start) - (while (< (point) end) - (when (bolp) - (skip-chars-forward " ")) - (add-face-text-property (point) (min (line-end-position) end) type t) - (if (< (line-end-position) end) - (forward-line 1) - (goto-char end))))) + (unless shr-inhibit-decoration + (save-excursion + (goto-char start) + (while (< (point) end) + (when (bolp) + (skip-chars-forward " ")) + (add-face-text-property (point) (min (line-end-position) end) type t) + (if (< (line-end-position) end) + (forward-line 1) + (goto-char end)))))) (defun shr-browse-url () "Browse the URL under point." @@ -802,12 +810,13 @@ START, and END. Note that START and END should be markers." (shr-ensure-paragraph)) (defun shr-urlify (start url &optional title) + (when (and title (string-match "ctx" title)) (debug)) (shr-add-font start (point) 'shr-link) (add-text-properties start (point) (list 'shr-url url - 'local-map shr-map - 'help-echo (if title (format "%s (%s)" url title) url)))) + 'help-echo (if title (format "%s (%s)" url title) url) + 'local-map shr-map))) (defun shr-encode-url (url) "Encode URL." @@ -839,13 +848,18 @@ ones, in case fg and bg are nil." (shr-color-visible bg fg))))))) (defun shr-colorize-region (start end fg &optional bg) - (when (or fg bg) + (when (and (not shr-inhibit-decoration) + (or fg bg)) (let ((new-colors (shr-color-check fg bg))) (when new-colors (when fg - (shr-add-font start end (list :foreground (cadr new-colors)))) + (add-face-text-property start end + (list :foreground (cadr new-colors)) + t)) (when bg - (shr-add-font start end (list :background (car new-colors))))) + (add-face-text-property start end + (list :background (car new-colors)) + t))) new-colors))) (defun shr-expand-newlines (start end color) @@ -1013,7 +1027,9 @@ ones, in case fg and bg are nil." plist))) (defun shr-tag-base (cont) - (setq shr-base (shr-parse-base (cdr (assq :href cont)))) + (let ((base (cdr (assq :href cont)))) + (when base + (setq shr-base (shr-parse-base base)))) (shr-generic cont)) (defun shr-tag-a (cont) @@ -1022,7 +1038,8 @@ ones, in case fg and bg are nil." (start (point)) shr-start) (shr-generic cont) - (when url + (when (and url + (not shr-inhibit-decoration)) (shr-urlify (or shr-start start) (shr-expand-url url) title)))) (defun shr-tag-object (cont) @@ -1159,11 +1176,7 @@ ones, in case fg and bg are nil." (shr-generic cont)) (defun shr-tag-span (cont) - (let ((title (cdr (assq :title cont)))) - (shr-generic cont) - (when (and title - shr-start) - (put-text-property shr-start (point) 'help-echo title)))) + (shr-generic cont)) (defun shr-tag-h1 (cont) (shr-heading cont 'bold 'underline)) @@ -1317,35 +1330,40 @@ ones, in case fg and bg are nil." (nreverse result))) (defun shr-insert-table (table widths) - (shr-insert-table-ruler widths) - (dolist (row table) - (let ((start (point)) - (height (let ((max 0)) - (dolist (column row) - (setq max (max max (cadr column)))) - max))) - (dotimes (i height) - (shr-indent) - (insert shr-table-vertical-line "\n")) - (dolist (column row) - (goto-char start) - (let ((lines (nth 2 column))) - (dolist (line lines) - (end-of-line) - (insert line shr-table-vertical-line) - (forward-line 1)) - ;; Add blank lines at padding at the bottom of the TD, - ;; possibly. - (dotimes (i (- height (length lines))) - (end-of-line) - (let ((start (point))) - (insert (make-string (string-width (car lines)) ? ) - shr-table-vertical-line) - (when (nth 4 column) - (shr-add-font start (1- (point)) - (list :background (nth 4 column))))) - (forward-line 1))))) - (shr-insert-table-ruler widths))) + (let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet)) + "collapse")) + (shr-table-vertical-line (if collapse "" shr-table-vertical-line))) + (unless collapse + (shr-insert-table-ruler widths)) + (dolist (row table) + (let ((start (point)) + (height (let ((max 0)) + (dolist (column row) + (setq max (max max (cadr column)))) + max))) + (dotimes (i height) + (shr-indent) + (insert shr-table-vertical-line "\n")) + (dolist (column row) + (goto-char start) + (let ((lines (nth 2 column))) + (dolist (line lines) + (end-of-line) + (insert line shr-table-vertical-line) + (forward-line 1)) + ;; Add blank lines at padding at the bottom of the TD, + ;; possibly. + (dotimes (i (- height (length lines))) + (end-of-line) + (let ((start (point))) + (insert (make-string (string-width (car lines)) ? ) + shr-table-vertical-line) + (when (nth 4 column) + (shr-add-font start (1- (point)) + (list :background (nth 4 column))))) + (forward-line 1))))) + (unless collapse + (shr-insert-table-ruler widths))))) (defun shr-insert-table-ruler (widths) (when (and (bolp) @@ -1398,7 +1416,8 @@ ones, in case fg and bg are nil." data))) (defun shr-make-table-1 (cont widths &optional fill) - (let ((trs nil)) + (let ((trs nil) + (shr-inhibit-decoration (not fill))) (dolist (row cont) (when (eq (car row) 'tr) (let ((tds nil) @@ -1454,11 +1473,23 @@ ones, in case fg and bg are nil." (if (zerop (buffer-size)) (insert (make-string width ? )) ;; Otherwise, fill the buffer. - (while (not (eobp)) - (end-of-line) - (when (> (- width (current-column)) 0) - (insert (make-string (- width (current-column)) ? ))) - (forward-line 1))) + (let ((align (cdr (assq :align cont))) + length) + (while (not (eobp)) + (end-of-line) + (setq length (- width (current-column))) + (when (> length 0) + (cond + ((equal align "right") + (beginning-of-line) + (insert (make-string length ? ))) + ((equal align "center") + (insert (make-string (/ length 2) ? )) + (beginning-of-line) + (insert (make-string (- length (/ length 2)) ? ))) + (t + (insert (make-string length ? ))))) + (forward-line 1)))) (when style (setq actual-colors (shr-colorize-region