X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fshr.el;h=bb9695ebb723f121429b8cc233d7b75ca4297e5e;hp=7d06ffbb7e8e9a420d578f555661836fb4f8d374;hb=b2ea476e0bc6e2973976b376c15be5381fe3127f;hpb=c9a58d3bdde1e6a8d653c1126f807da23441e459 diff --git a/lisp/shr.el b/lisp/shr.el index 7d06ffbb7..bb9695ebb 100644 --- a/lisp/shr.el +++ b/lisp/shr.el @@ -1,6 +1,6 @@ ;;; shr.el --- Simple HTML Renderer -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010-2011 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: html @@ -74,8 +74,12 @@ fit these criteria." :type 'character) (defcustom shr-width fill-column - "Frame width to use for rendering." - :type 'integer + "Frame width to use for rendering. +May either be an integer specifying a fixed width in characters, +or nil, meaning that the full width of the window should be +used." + :type '(choice (integer :tag "Fixed width in characters") + (const :tag "Use the width of the window" nil)) :group 'shr) (defvar shr-content-function nil @@ -113,7 +117,8 @@ cid: URL as the argument.") (defun shr-insert-document (dom) (setq shr-content-cache nil) (let ((shr-state nil) - (shr-start nil)) + (shr-start nil) + (shr-width (or shr-width (window-width)))) (shr-descend (shr-transform-dom dom)))) (defun shr-copy-url () @@ -253,16 +258,12 @@ redirects somewhere else." (when (and (bolp) (> shr-indentation 0)) (shr-indent)) - ;; The shr-start is a special variable that is used to pass - ;; upwards the first point in the buffer where the text really - ;; starts. - (unless shr-start - (setq shr-start (point))) ;; No space is needed behind a wide character categorized as ;; kinsoku-bol, between characters both categorized as nospace, ;; or at the beginning of a line. (let (prev) - (when (and (eq (preceding-char) ? ) + (when (and (> (current-column) shr-indentation) + (eq (preceding-char) ? ) (or (= (line-beginning-position) (1- (point))) (and (shr-char-breakable-p (setq prev (char-after (- (point) 2)))) @@ -270,6 +271,11 @@ redirects somewhere else." (and (shr-char-nospace-p prev) (shr-char-nospace-p (aref elem 0))))) (delete-char -1))) + ;; The shr-start is a special variable that is used to pass + ;; upwards the first point in the buffer where the text really + ;; starts. + (unless shr-start + (setq shr-start (point))) (insert elem) (let (found) (while (and (> (current-column) shr-width) @@ -456,11 +462,12 @@ redirects somewhere else." (search-forward "\r\n\r\n" nil t)) (let ((data (buffer-substring (point) (point-max)))) (with-current-buffer buffer - (let ((alt (buffer-substring start end)) - (inhibit-read-only t)) - (delete-region start end) - (goto-char start) - (shr-put-image data alt)))))) + (save-excursion + (let ((alt (buffer-substring start end)) + (inhibit-read-only t)) + (delete-region start end) + (goto-char start) + (shr-put-image data alt))))))) (kill-buffer (current-buffer))) (defun shr-put-image (data alt) @@ -501,6 +508,9 @@ redirects somewhere else." (create-image data 'imagemagick t :width window-width) image))) + (when (and (fboundp 'create-animated-image) + (eq (image-type data nil t) 'gif)) + (setq image (create-animated-image data 'gif t))) image))) ;; url-cache-extract autoloads url-cache. @@ -524,7 +534,7 @@ Return a string with image data." "Return a function to display an image. CONTENT-FUNCTION is a function to retrieve an image for a cid url that is an argument. The function to be returned takes three arguments URL, -START, and END." +START, and END. Note that START and END should be merkers." `(lambda (url start end) (when url (if (string-match "\\`cid:" url) @@ -534,9 +544,8 @@ START, and END." (when image (goto-char start) (shr-put-image image - (prog1 - (buffer-substring-no-properties start end) - (delete-region start end)))))) + (buffer-substring-no-properties start end)) + (delete-region (point) end)))) (url-retrieve url 'shr-image-fetched (list (current-buffer) start end) t))))) @@ -592,7 +601,8 @@ ones, in case fg and bg are nil." (when fg (shr-put-color start end :foreground (cadr new-colors))) (when bg - (shr-put-color start end :background (car new-colors))))))) + (shr-put-color start end :background (car new-colors)))) + new-colors))) ;; Put a color in the region, but avoid putting colors on on blank ;; text at the start of the line, and the newline at the end, to avoid @@ -603,13 +613,67 @@ ones, in case fg and bg are nil." (save-excursion (goto-char start) (while (< (point) end) - (when (bolp) + (when (and (bolp) + (not (eq type :background))) (skip-chars-forward " ")) (when (> (line-end-position) (point)) (shr-put-color-1 (point) (min (line-end-position) end) type color)) (if (< (line-end-position) end) (forward-line 1) - (goto-char end))))) + (goto-char end))) + (when (and (eq type :background) + (= shr-table-depth 0)) + (shr-expand-newlines start end color)))) + +(defun shr-expand-newlines (start end color) + (save-restriction + ;; Skip past all white space at the start and ends. + (goto-char start) + (skip-chars-forward " \t\n") + (beginning-of-line) + (setq start (point)) + (goto-char end) + (skip-chars-backward " \t\n") + (forward-line 1) + (setq end (point)) + (narrow-to-region start end) + (let ((width (shr-natural-width)) + column) + (goto-char (point-min)) + (while (not (eobp)) + (end-of-line) + (when (and (< (setq column (current-column)) width) + (< (setq column (shr-previous-newline-padding-width column)) + width)) + (let ((overlay (make-overlay (point) (1+ (point))))) + (overlay-put overlay 'before-string + (concat + (mapconcat + (lambda (overlay) + (let ((string (plist-get + (overlay-properties overlay) + 'before-string))) + (if (not string) + "" + (overlay-put overlay 'before-string "") + string))) + (overlays-at (point)) + "") + (propertize (make-string (- width column) ? ) + 'face (list :background color)))))) + (forward-line 1))))) + +(defun shr-previous-newline-padding-width (width) + (let ((overlays (overlays-at (point))) + (previous-width 0)) + (if (null overlays) + width + (dolist (overlay overlays) + (setq previous-width + (+ previous-width + (length (plist-get (overlay-properties overlay) + 'before-string))))) + (+ width previous-width)))) (defun shr-put-color-1 (start end type color) (let* ((old-props (get-text-property start 'face)) @@ -632,7 +696,8 @@ ones, in case fg and bg are nil." (defun shr-tag-body (cont) (let* ((start (point)) - (fgcolor (cdr (assq :fgcolor cont))) + (fgcolor (cdr (or (assq :fgcolor cont) + (assq :text cont)))) (bgcolor (cdr (assq :bgcolor cont))) (shr-stylesheet (list (cons 'color fgcolor) (cons 'background-color bgcolor)))) @@ -642,6 +707,13 @@ ones, in case fg and bg are nil." (defun shr-tag-style (cont) ) +(defun shr-tag-script (cont) + ) + +(defun shr-tag-label (cont) + (shr-generic cont) + (shr-ensure-paragraph)) + (defun shr-tag-p (cont) (shr-ensure-paragraph) (shr-indent) @@ -898,8 +970,8 @@ ones, in case fg and bg are nil." (footer (cdr (assq 'tfoot cont))) (bgcolor (cdr (assq :bgcolor cont))) (start (point)) - (shr-stylesheet (nconc (list (cons 'color bgcolor) - shr-stylesheet))) + (shr-stylesheet (nconc (list (cons 'background-color bgcolor)) + shr-stylesheet)) (nheader (if header (shr-max-columns header))) (nbody (if body (shr-max-columns body))) (nfooter (if footer (shr-max-columns footer)))) @@ -942,8 +1014,7 @@ ones, in case fg and bg are nil." `((tr (td (table (tbody ,@body))))) body))))) (when bgcolor - (shr-colorize-region start (point) - nil + (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet)) bgcolor)))) (defun shr-find-elements (cont type) @@ -986,8 +1057,11 @@ ones, in case fg and bg are nil." ;; possibly. (dotimes (i (- height (length lines))) (end-of-line) - (insert (make-string (string-width (car lines)) ? ) - shr-table-vertical-line) + (let ((start (point))) + (insert (make-string (string-width (car lines)) ? ) + shr-table-vertical-line) + (when (nth 4 column) + (shr-put-color start (1- (point)) :background (nth 4 column)))) (forward-line 1))))) (shr-insert-table-ruler widths))) @@ -1052,16 +1126,31 @@ ones, in case fg and bg are nil." (with-temp-buffer (let ((bgcolor (cdr (assq :bgcolor cont))) (fgcolor (cdr (assq :fgcolor cont))) - (shr-stylesheet shr-stylesheet)) + (style (cdr (assq :style cont))) + (shr-stylesheet shr-stylesheet) + overlays actual-colors) + (when style + (setq style (and (string-match "color" style) + (shr-parse-style style)))) (when bgcolor - (setq shr-stylesheet (nconc (list 'background-color bgcolor) - shr-stylesheet))) + (setq style (nconc (list (cons 'background-color bgcolor)) style))) (when fgcolor - (setq shr-stylesheet (nconc (list 'background-color fgcolor) - shr-stylesheet))) + (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 - (insert cache) + (progn + (insert (car cache)) + (let ((end (length (car cache)))) + (dolist (overlay (cadr cache)) + (let ((new-overlay + (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))) @@ -1069,7 +1158,8 @@ ones, in case fg and bg are nil." (point) (+ (point) (skip-chars-backward " \t\n"))) - (push (cons (cons width cont) (buffer-string)) + (push (list (cons width cont) (buffer-string) + (shr-overlays-in-region (point-min) (point-max))) shr-content-cache))) (goto-char (point-min)) (let ((max 0)) @@ -1088,14 +1178,19 @@ ones, in case fg and bg are nil." (end-of-line) (when (> (- width (current-column)) 0) (insert (make-string (- width (current-column)) ? ))) - (forward-line 1)))) - (when (or bgcolor fgcolor) - (shr-colorize-region (point-min) (point-max) fgcolor bgcolor)) + (forward-line 1))) + (when style + (setq actual-colors + (shr-colorize-region + (point-min) (point-max) + (cdr (assq 'color shr-stylesheet)) + (cdr (assq 'background-color shr-stylesheet)))))) (if fill (list max (count-lines (point-min) (point-max)) (split-string (buffer-string) "\n") - (shr-collect-overlays)) + (shr-collect-overlays) + (car actual-colors)) (list max (shr-natural-width)))))))