X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fshr.el;h=2d477fddd994ff7715acb3429bd085c687bd0e1d;hb=5beb390633ce1e32cdf319c6ba19926244bbfdf2;hp=47622f5183d2fa25577bee9f8376ef1a433c4918;hpb=3614422b660cbb37541de79822260a74f359fb55;p=gnus diff --git a/lisp/shr.el b/lisp/shr.el index 47622f518..2d477fddd 100644 --- a/lisp/shr.el +++ b/lisp/shr.el @@ -119,6 +119,7 @@ cid: URL as the argument.") (let ((map (make-sparse-keymap))) (define-key map "a" 'shr-show-alt-text) (define-key map "i" 'shr-browse-image) + (define-key map "z" 'shr-zoom-image) (define-key map "I" 'shr-insert-image) (define-key map "u" 'shr-copy-url) (define-key map "v" 'shr-browse-url) @@ -160,7 +161,7 @@ DOM should be a parse tree as generated by (goto-char start) (while (not (eobp)) (end-of-line) - (when (> (current-column) width) + (when (> (shr-previous-newline-padding-width (current-column)) width) (dolist (overlay (overlays-at (point))) (when (overlay-get overlay 'before-string) (overlay-put overlay 'before-string nil)))) @@ -235,6 +236,40 @@ the URL of the image to the kill buffer instead." (list (current-buffer) (1- (point)) (point-marker)) t t)))) +(defun shr-zoom-image () + "Toggle the image size. +The size will be rotated between the default size, the original +size, and full-buffer size." + (interactive) + (let ((url (get-text-property (point) 'image-url)) + (size (get-text-property (point) 'image-size)) + (buffer-read-only nil)) + (if (not url) + (message "No image under point") + ;; Delete the old picture. + (while (get-text-property (point) 'image-url) + (forward-char -1)) + (forward-char 1) + (let ((start (point))) + (while (get-text-property (point) 'image-url) + (forward-char 1)) + (forward-char -1) + (put-text-property start (point) 'display nil) + (when (> (- (point) start) 2) + (delete-region start (1- (point))))) + (message "Inserting %s..." url) + (url-retrieve url 'shr-image-fetched + (list (current-buffer) (1- (point)) (point-marker) + (list (cons 'size + (cond ((or (eq size 'default) + (null size)) + 'original) + ((eq size 'original) + 'full) + ((eq size 'full) + 'default))))) + t)))) + ;;; Utility functions. (defun shr-transform-dom (dom) @@ -341,7 +376,6 @@ the URL of the image to the kill buffer instead." (delete-char -1)) (insert "\n") (unless found - (put-text-property (1- (point)) (point) 'shr-break t) ;; No space is needed at the beginning of a line. (when (eq (following-char) ? ) (delete-char 1))) @@ -523,42 +557,65 @@ the URL of the image to the kill buffer instead." (expand-file-name (file-name-nondirectory url) directory))))) -(defun shr-image-fetched (status buffer start end) - (when (and (buffer-name buffer) - (not (plist-get status :error))) - (url-store-in-cache (current-buffer)) - (when (or (search-forward "\n\n" nil t) - (search-forward "\r\n\r\n" nil t)) - (let ((data (buffer-substring (point) (point-max)))) - (with-current-buffer buffer - (save-excursion - (let ((alt (buffer-substring start end)) - (inhibit-read-only t)) - (delete-region start end) - (goto-char start) - (funcall shr-put-image-function data alt))))))) - (kill-buffer (current-buffer))) - -(defun shr-put-image (data alt) +(defun shr-image-fetched (status buffer start end &optional flags) + (let ((image-buffer (current-buffer))) + (when (and (buffer-name buffer) + (not (plist-get status :error))) + (url-store-in-cache image-buffer) + (when (or (search-forward "\n\n" nil t) + (search-forward "\r\n\r\n" nil t)) + (let ((data (buffer-substring (point) (point-max)))) + (with-current-buffer buffer + (save-excursion + (let ((alt (buffer-substring start end)) + (properties (text-properties-at start)) + (inhibit-read-only t)) + (delete-region start end) + (goto-char start) + (funcall shr-put-image-function data alt flags) + (while properties + (let ((type (pop properties)) + (value (pop properties))) + (unless (memq type '(display image-size)) + (put-text-property start (point) type value)))))))))) + (kill-buffer image-buffer))) + +(defun shr-put-image (data alt &optional flags) "Put image DATA with a string ALT. Return image." (if (display-graphic-p) - (let ((image (ignore-errors - (shr-rescale-image data)))) + (let* ((size (cdr (assq 'size flags))) + (start (point)) + (image (cond + ((eq size 'original) + (create-image data nil t :ascent 100)) + ((eq size 'full) + (ignore-errors + (shr-rescale-image data t))) + (t + (ignore-errors + (shr-rescale-image data)))))) (when image ;; When inserting big-ish pictures, put them at the ;; beginning of the line. (when (and (> (current-column) 0) (> (car (image-size image t)) 400)) (insert "\n")) - (insert-image image (or alt "*")) + (if (eq size 'original) + (let ((overlays (overlays-at (point)))) + (insert-sliced-image image (or alt "*") nil 20 1) + (dolist (overlay overlays) + (overlay-put overlay 'face 'default))) + (insert-image image (or alt "*"))) + (put-text-property start (point) 'image-size size) (when (image-animated-p image) (image-animate image nil 60))) image) (insert alt))) -(defun shr-rescale-image (data) - (let* ((max-image-size nil) - (image (create-image data nil t :ascent 100))) +(defun shr-rescale-image (data &optional force) + "Rescale DATA, if too big, to fit the current buffer. +If FORCE, rescale the image anyway." + (let ((image (create-image data nil t :ascent 100))) (if (or (not (fboundp 'imagemagick-types)) (not (get-buffer-window (current-buffer)))) image @@ -572,7 +629,8 @@ the URL of the image to the kill buffer instead." (window-height (truncate (* shr-max-image-proportion (- (nth 3 edges) (nth 1 edges))))) scaled-image) - (when (> height window-height) + (when (or force + (> height window-height)) (setq image (or (create-image data 'imagemagick t :height window-height :ascent 100) @@ -711,7 +769,7 @@ ones, in case fg and bg are nil." (forward-line 1) (setq end (point)) (narrow-to-region start end) - (let ((width (shr-natural-width)) + (let ((width (shr-buffer-width)) column) (goto-char (point-min)) (while (not (eobp)) @@ -1048,7 +1106,10 @@ ones, in case fg and bg are nil." ;; be smaller (if there's little text) or bigger (if there's ;; unbreakable text). (sketch (shr-make-table cont suggested-widths)) - (sketch-widths (shr-table-widths sketch suggested-widths))) + ;; Compute the "natural" width by setting each column to 500 + ;; characters and see how wide they really render. + (natural (shr-make-table cont (make-vector (length columns) 500))) + (sketch-widths (shr-table-widths sketch natural suggested-widths))) ;; This probably won't work very well. (when (> (+ (loop for width across sketch-widths summing (1+ width)) @@ -1186,31 +1247,35 @@ ones, in case fg and bg are nil." shr-table-corner)) (insert "\n")) -(defun shr-table-widths (table suggested-widths) +(defun shr-table-widths (table natural-table suggested-widths) (let* ((length (length suggested-widths)) (widths (make-vector length 0)) (natural-widths (make-vector length 0))) (dolist (row table) (let ((i 0)) (dolist (column row) - (aset widths i (max (aref widths i) - (car column))) - (aset natural-widths i (max (aref natural-widths i) - (cadr column))) + (aset widths i (max (aref widths i) column)) + (setq i (1+ i))))) + (dolist (row natural-table) + (let ((i 0)) + (dolist (column row) + (aset natural-widths i (max (aref natural-widths i) column)) (setq i (1+ i))))) (let ((extra (- (apply '+ (append suggested-widths nil)) (apply '+ (append widths nil)))) (expanded-columns 0)) + ;; We have extra, unused space, so divide this space amongst the + ;; columns. (when (> extra 0) + ;; If the natural width is wider than the rendered width, we + ;; want to allow the column to expand. (dotimes (i length) - ;; If the natural width is wider than the rendered width, we - ;; want to allow the column to expand. (when (> (aref natural-widths i) (aref widths i)) (setq expanded-columns (1+ expanded-columns)))) (dotimes (i length) (when (> (aref natural-widths i) (aref widths i)) (aset widths i (min - (1+ (aref natural-widths i)) + (aref natural-widths i) (+ (/ extra expanded-columns) (aref widths i)))))))) widths)) @@ -1265,10 +1330,13 @@ ones, in case fg and bg are nil." (let ((shr-width width) (shr-indentation 0)) (shr-descend (cons 'td cont))) + ;; Delete padding at the bottom of the TDs. (delete-region (point) - (+ (point) - (skip-chars-backward " \t\n"))) + (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))) @@ -1302,19 +1370,14 @@ ones, in case fg and bg are nil." (split-string (buffer-string) "\n") (shr-collect-overlays) (car actual-colors)) - (list max - (shr-natural-width))))))) + max))))) -(defun shr-natural-width () +(defun shr-buffer-width () (goto-char (point-min)) - (let ((current 0) - (max 0)) + (let ((max 0)) (while (not (eobp)) (end-of-line) - (setq current (+ current (current-column))) - (unless (get-text-property (point) 'shr-break) - (setq max (max max current) - current 0)) + (setq max (max max (current-column))) (forward-line 1)) max)) @@ -1364,10 +1427,10 @@ ones, in case fg and bg are nil." (when (memq (car column) '(td th)) (let ((width (cdr (assq :width (cdr column))))) (when (and width - (string-match "\\([0-9]+\\)%" width)) - (aset columns i - (/ (string-to-number (match-string 1 width)) - 100.0)))) + (string-match "\\([0-9]+\\)%" width) + (not (zerop (setq width (string-to-number + (match-string 1 width)))))) + (aset columns i (/ width 100.0)))) (setq i (1+ i))))))) columns))