Mercurial > emacs

changeset 110747:0defef1647a5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge changes made in Gnus trunk. shr.el: Rename the tag functions a bit, and add some new ones. gnus-sum.el (gnus-summary-select-article-buffer): If the article buffer isn't shown, then select the current article first instead of bugging out. gnus-sum.el (gnus-summary-select-article-buffer): Show both the article and summary buffers again. shr.el (shr-tag-blockquote): Convert name. shr.el (shr-rescale-image): Use the right image-size variant. shr.el (shr-tag-p): Don't insert newlines at the start of the buffer. shr.el: Implement indentation in blockquotes. gnus-sum.el (gnus-summary-select-article-buffer): Really select the article buffer again. shr.el (shr-ensure-paragraph): Don't insert newlines on empty tags at the beginning of the buffer. gnus-ems.el, gnus-util.el, mm-decode.el, mm-view.el: Add resize for large images in mm. gnus-html.el (gnus-html-put-image): Use gnus-rescale-image. shr.el (shr-tag-p): Don't insert newlines on empty tags at the beginning of the buffer. gnus-ems.el, gnus-html.el, gnus-util.el, mm-decode.el, mm-view.el: Support image resizing. shr.el: Add headings. shr.el (shr-ensure-paragraph): Actually work. shr.el (shr-tag-li): Make <ul> prettier. shr.el (shr-insert): Get white space at the beginning/end of elements right. shr.el (shr-tag-li): Tweak <li> rendering. shr.el (shr-tag-p): Collapse subsequent <p>s. shr.el (shr-ensure-paragraph): Don't insert double line feeds after blank lines. shr.el (shr-tag-h6): Add. shr.el (shr-insert): \t is also space.
author Katsumi Yamaoka <yamaoka@jpl.org>
date Mon, 04 Oct 2010 00:17:16 +0000
parents 5c1a707ab452
children 2279efb0250e
files doc/misc/ChangeLog doc/misc/emacs-mime.texi lisp/gnus/ChangeLog lisp/gnus/gnus-ems.el lisp/gnus/gnus-html.el lisp/gnus/gnus-sum.el lisp/gnus/gnus-util.el lisp/gnus/mm-decode.el lisp/gnus/mm-view.el lisp/gnus/shr.el
diffstat 10 files changed, 250 insertions(+), 69 deletions(-) [+]
line wrap: on
line diff
--- a/doc/misc/ChangeLog	Sun Oct 03 16:35:22 2010 -0700
+++ b/doc/misc/ChangeLog	Mon Oct 04 00:17:16 2010 +0000
@@ -1,3 +1,9 @@
+2010-10-03  Julien Danjou  <julien@danjou.info>
+
+	* emacs-mime.texi (Display Customization): Update
+	mm-inline-large-images documentation and add documentation for
+	mm-inline-large-images-proportion.
+
 2010-10-03  Michael Albinus  <michael.albinus@gmx.de>
 
 	* tramp.texi (Frequently Asked Questions): Mention
--- a/doc/misc/emacs-mime.texi	Sun Oct 03 16:35:22 2010 -0700
+++ b/doc/misc/emacs-mime.texi	Mon Oct 04 00:17:16 2010 +0000
@@ -374,12 +374,18 @@
 @vindex mm-inline-large-images
 When displaying inline images that are larger than the window, Emacs
 does not enable scrolling, which means that you cannot see the whole
-image.  To prevent this, the library tries to determine the image size
+image. To prevent this, the library tries to determine the image size
 before displaying it inline, and if it doesn't fit the window, the
 library will display it externally (e.g. with @samp{ImageMagick} or
-@samp{xv}).  Setting this variable to @code{t} disables this check and
+@samp{xv}). Setting this variable to @code{t} disables this check and
 makes the library display all inline images as inline, regardless of
-their size.
+their size. If you set this variable to @code{resize}, the image will
+be displayed resized to fit in the window, if Emacs has the ability to
+resize images.
+
+@item mm-inline-large-images-proportion
+@vindex mm-inline-images-max-proportion
+The proportion used when resizing large images.
 
 @item mm-inline-override-types
 @vindex mm-inline-override-types
--- a/lisp/gnus/ChangeLog	Sun Oct 03 16:35:22 2010 -0700
+++ b/lisp/gnus/ChangeLog	Mon Oct 04 00:17:16 2010 +0000
@@ -1,3 +1,61 @@
+2010-10-03  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+	* shr.el: Add headings.
+	(shr-ensure-paragraph): Actually work.
+	(shr-tag-li): Make <ul> prettier.
+	(shr-insert): Get white space at the beginning/end of elements right.
+	(shr-tag-p): Collapse subsequent <p>s.
+	(shr-ensure-paragraph): Don't insert double line feeds after blank
+	lines.
+	(shr-insert): \t is also space.
+	(shr-tag-s): Fix "s" tag name function.
+	(shr-tag-s): Fix face prop name.
+
+2010-10-03  Julien Danjou  <julien@danjou.info>
+
+	* gnus-html.el (gnus-html-put-image): Use gnus-rescale-image.
+
+	* mm-view.el (gnus-window-inside-pixel-edges): Add autoload for
+	gnus-window-inside-pixel-edges.
+
+	* gnus-ems.el (gnus-window-inside-pixel-edges): Move from gnus-html to
+	gnus-ems.
+
+	* mm-view.el (mm-inline-image-emacs): Support image resizing.
+
+	* gnus-util.el (gnus-rescale-image): Add generic gnus-rescale-image
+	function.
+
+	* mm-decode.el (mm-inline-large-images): Enhance defcustom and add
+	resize choice.
+
+2010-10-03  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+	* shr.el (shr-tag-p): Don't insert newlines on empty tags at the
+	beginning of the buffer.
+
+	* gnus-sum.el (gnus-summary-select-article-buffer): Really select the
+	article buffer again.
+
+	* shr.el (shr-tag-p): Don't insert newlines at the start of the
+	buffer.
+
+	* mm-decode.el (mm-shr): Narrow before inserting, so that shr can know
+	when it's at the start of the buffer.
+
+	* shr.el (shr-tag-blockquote): Convert name.
+	(shr-rescale-image): Use the right image-size variant.
+
+	* gnus-sum.el (gnus-summary-select-article-buffer): If the article
+	buffer isn't shown, then select the current article first instead of
+	bugging out.
+	(gnus-summary-select-article-buffer): Show both the article and summary
+	buffers again.
+
+	* shr.el (shr-fontize-cont): Protect against regions with no text.
+	Rename tag functions to shr-tag-* for enhanced security.
+	(shr-tag-ul, shr-tag-ol, shr-tag-li, shr-tag-br): New functions.
+
 2010-10-03  Chong Yidong  <cyd@stupidchicken.com>
 
 	* shr.el (shr-insert):
--- a/lisp/gnus/gnus-ems.el	Sun Oct 03 16:35:22 2010 -0700
+++ b/lisp/gnus/gnus-ems.el	Mon Oct 04 00:17:16 2010 +0000
@@ -307,6 +307,12 @@
 		end nil))))))
 
 (eval-and-compile
+  ;; XEmacs does not have window-inside-pixel-edges
+  (defalias 'gnus-window-inside-pixel-edges
+    (if (fboundp 'window-inside-pixel-edges)
+        'window-inside-pixel-edges
+      'window-pixel-edges))
+
   (if (fboundp 'set-process-plist)
       (progn
 	(defalias 'gnus-set-process-plist 'set-process-plist)
--- a/lisp/gnus/gnus-html.el	Sun Oct 03 16:35:22 2010 -0700
+++ b/lisp/gnus/gnus-html.el	Mon Oct 04 00:17:16 2010 +0000
@@ -105,12 +105,7 @@
 					  (match-string 0 encoded-text)))
 				 t t encoded-text)
 		  s (1+ s)))
-	  encoded-text))))
-  ;; XEmacs does not have window-inside-pixel-edges
-  (defalias 'gnus-window-inside-pixel-edges
-    (if (fboundp 'window-inside-pixel-edges)
-        'window-inside-pixel-edges
-      'window-pixel-edges)))
+	  encoded-text)))))
 
 (defun gnus-html-encode-url (url)
   "Encode URL."
@@ -436,7 +431,17 @@
                                  (= (car size) 30)
                                  (= (cdr size) 30))))
                   ;; Good image, add it!
-                  (let ((image (gnus-html-rescale-image image data size)))
+                  (let ((image (gnus-html-rescale-image
+                                image
+                                ;; (width . height)
+                                (cons
+                                 ;; Aimed width
+                                 (truncate
+                                  (* gnus-max-image-proportion
+                                     (- (nth 2 edges) (nth 0 edges))))
+                                 ;; Aimed height
+                                 (truncate (* gnus-max-image-proportion
+                                              (- (nth 3 edges) (nth 1 edges))))))))
                     (delete-region start end)
                     (gnus-put-image image alt-text 'external)
                     (gnus-put-text-property start (point) 'help-echo alt-text)
@@ -459,31 +464,6 @@
                   (gnus-add-image 'internal image))
                 nil))))))))
 
-(defun gnus-html-rescale-image (image data size)
-  (if (or (not (fboundp 'imagemagick-types))
-	  (not (get-buffer-window (current-buffer))))
-      image
-    (let* ((width (car size))
-	   (height (cdr size))
-	   (edges (gnus-window-inside-pixel-edges
-		   (get-buffer-window (current-buffer))))
-	   (window-width (truncate (* gnus-max-image-proportion
-				      (- (nth 2 edges) (nth 0 edges)))))
-	   (window-height (truncate (* gnus-max-image-proportion
-				       (- (nth 3 edges) (nth 1 edges)))))
-	   scaled-image)
-      (when (> height window-height)
-	(setq image (or (create-image data 'imagemagick t
-				      :height window-height)
-			image))
-	(setq size (image-size image t)))
-      (when (> (car size) window-width)
-	(setq image (or
-		     (create-image data 'imagemagick t
-				   :width window-width)
-		     image)))
-      image)))
-
 (defun gnus-html-image-url-blocked-p (url blocked-images)
   "Find out if URL is blocked by BLOCKED-IMAGES."
   (let ((ret (and blocked-images
--- a/lisp/gnus/gnus-sum.el	Sun Oct 03 16:35:22 2010 -0700
+++ b/lisp/gnus/gnus-sum.el	Mon Oct 04 00:17:16 2010 +0000
@@ -6933,8 +6933,10 @@
   (interactive)
   (if (not (gnus-buffer-live-p gnus-article-buffer))
       (error "There is no article buffer for this summary buffer")
-    (select-window (get-buffer-window gnus-article-buffer))
-    (gnus-configure-windows 'only-article t)))
+    (unless (get-buffer-window gnus-article-buffer)
+      (gnus-summary-show-article))
+    (gnus-configure-windows 'article t)
+    (select-window (get-buffer-window gnus-article-buffer))))
 
 (defun gnus-summary-universal-argument (arg)
   "Perform any operation on all articles that are process/prefixed."
--- a/lisp/gnus/gnus-util.el	Sun Oct 03 16:35:22 2010 -0700
+++ b/lisp/gnus/gnus-util.el	Mon Oct 04 00:17:16 2010 +0000
@@ -1932,6 +1932,26 @@
             (get-char-table ,character ,display-table)))
     `(aref ,display-table ,character)))
 
+(defun gnus-rescale-image (image size)
+  "Rescale IMAGE to SIZE if possible.
+SIZE is in format (WIDTH . HEIGHT). Return a new image.
+Sizes are in pixels."
+  (if (or (not (fboundp 'imagemagick-types))
+	  (not (get-buffer-window (current-buffer))))
+      image
+    (let ((new-width (car size))
+          (new-height (cdr size)))
+      (when (> (cdr (image-size image t)) new-height)
+        (setq image (or (create-image (plist-get (cdr image) :data) 'imagemagick t
+                                      :height new-height)
+                        image)))
+      (when (> (car (image-size image t)) new-width)
+        (setq image (or
+                   (create-image (plist-get (cdr image) :data) 'imagemagick t
+                                 :width new-width)
+                   image)))
+      image)))
+
 (provide 'gnus-util)
 
 ;;; gnus-util.el ends here
--- a/lisp/gnus/mm-decode.el	Sun Oct 03 16:35:22 2010 -0700
+++ b/lisp/gnus/mm-decode.el	Mon Oct 04 00:17:16 2010 +0000
@@ -369,8 +369,12 @@
   :group 'mime-display)
 
 (defcustom mm-inline-large-images nil
-  "If non-nil, then all images fit in the buffer."
-  :type 'boolean
+  "If t, then all images fit in the buffer.
+If 'resize, try to resize the images so they fit."
+  :type '(radio
+          (const :tag "Inline large images as they are." t)
+          (const :tag "Resize large images." resize)
+          (const :tag "Do not inline large images." nil))
   :group 'mime-display)
 
 (defcustom mm-file-name-rewrite-functions
@@ -1679,9 +1683,11 @@
   (let ((article-buffer (current-buffer)))
     (unless handle
       (setq handle (mm-dissect-buffer t)))
-    (shr-insert-document
-     (mm-with-part handle
-       (libxml-parse-html-region (point-min) (point-max))))))
+    (save-restriction
+      (narrow-to-region (point) (point))
+      (shr-insert-document
+       (mm-with-part handle
+	 (libxml-parse-html-region (point-min) (point-max)))))))
 
 (provide 'mm-decode)
 
--- a/lisp/gnus/mm-view.el	Sun Oct 03 16:35:22 2010 -0700
+++ b/lisp/gnus/mm-view.el	Mon Oct 04 00:17:16 2010 +0000
@@ -32,6 +32,7 @@
 (require 'smime)
 
 (autoload 'gnus-completing-read "gnus-util")
+(autoload 'gnus-window-inside-pixel-edges "gnus-ems")
 (autoload 'gnus-article-prepare-display "gnus-art")
 (autoload 'vcard-parse-string "vcard")
 (autoload 'vcard-format-string "vcard")
@@ -76,6 +77,13 @@
   :version "22.1"
   :group 'mime-display)
 
+(defcustom mm-inline-large-images-proportion 0.9
+  "Maximum proportion of large image resized when
+`mm-inline-large-images' is set to resize."
+  :type 'float
+  :version "24.1"
+  :group 'mime-display)
+
 ;;; Internal variables.
 
 ;;;
@@ -85,7 +93,18 @@
 (defun mm-inline-image-emacs (handle)
   (let ((b (point-marker))
 	(inhibit-read-only t))
-    (put-image (mm-get-image handle) b)
+    (put-image
+     (let ((image (mm-get-image handle)))
+       (if (eq mm-inline-large-images 'resize)
+           (gnus-rescale-image image
+                               (let ((edges (gnus-window-inside-pixel-edges
+                                             (get-buffer-window (current-buffer)))))
+                                 (cons (truncate (* mm-inline-large-images-proportion
+                                                    (- (nth 2 edges) (nth 0 edges))))
+                                       (truncate (* mm-inline-large-images-proportion
+                                                    (- (nth 3 edges) (nth 1 edges)))))))
+         image))
+     b)
     (insert "\n\n")
     (mm-handle-set-undisplayer
      handle
--- a/lisp/gnus/shr.el	Sun Oct 03 16:35:22 2010 -0700
+++ b/lisp/gnus/shr.el	Mon Oct 04 00:17:16 2010 +0000
@@ -53,6 +53,7 @@
 (defvar shr-folding-mode nil)
 (defvar shr-state nil)
 (defvar shr-start nil)
+(defvar shr-indentation 0)
 
 (defvar shr-width 70)
 
@@ -75,7 +76,7 @@
     (shr-descend (shr-transform-dom dom))))
 
 (defun shr-descend (dom)
-  (let ((function (intern (concat "shr-" (symbol-name (car dom))) obarray)))
+  (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray)))
     (if (fboundp function)
 	(funcall function (cdr dom))
       (shr-generic (cdr dom)))))
@@ -85,37 +86,48 @@
     (cond
      ((eq (car sub) :text)
       (shr-insert (cdr sub)))
-     ((consp (cdr sub))
+     ((listp (cdr sub))
       (shr-descend sub)))))
 
-(defun shr-p (cont)
-  (shr-ensure-newline)
-  (insert "\n")
+(defun shr-tag-p (cont)
+  (shr-ensure-paragraph)
   (shr-generic cont)
-  (insert "\n"))
+  (shr-ensure-paragraph))
 
-(defun shr-b (cont)
+(defun shr-ensure-paragraph ()
+  (unless (bobp)
+    (if (bolp)
+	(unless (eql (char-after (- (point) 2)) ?\n)
+	  (insert "\n"))
+      (if (save-excursion
+	    (beginning-of-line)
+	    (looking-at " *"))
+	  (insert "\n")
+	(insert "\n\n")))))
+
+(defun shr-tag-b (cont)
   (shr-fontize-cont cont 'bold))
 
-(defun shr-i (cont)
+(defun shr-tag-i (cont)
   (shr-fontize-cont cont 'italic))
 
-(defun shr-u (cont)
+(defun shr-tag-u (cont)
   (shr-fontize-cont cont 'underline))
 
-(defun shr-s (cont)
-  (shr-fontize-cont cont 'strikethru))
+(defun shr-tag-s (cont)
+  (shr-fontize-cont cont 'strike-through))
 
-(defun shr-fontize-cont (cont type)
+(defun shr-fontize-cont (cont &rest types)
   (let (shr-start)
     (shr-generic cont)
-    (shr-add-font shr-start (point) type)))
+    (dolist (type types)
+      (shr-add-font (or shr-start (point)) (point) type))))
 
 (defun shr-add-font (start end type)
   (let ((overlay (make-overlay start end)))
     (overlay-put overlay 'face type)))
 
-(defun shr-a (cont)
+(defun shr-tag-a (cont)
   (let ((url (cdr (assq :href cont)))
 	shr-start)
     (shr-generic cont)
@@ -129,7 +141,10 @@
 (defun shr-browse-url (widget &rest stuff)
   (browse-url (widget-get widget :url)))
 
-(defun shr-img (cont)
+(defun shr-tag-img (cont)
+  (when (and (> (current-column) 0)
+	     (not (eq shr-state 'image)))
+    (insert "\n"))
   (let ((start (point-marker)))
     (let ((alt (cdr (assq :alt cont)))
 	  (url (cdr (assq :src cont))))
@@ -166,15 +181,17 @@
 (defun shr-put-image (data point alt)
   (if (not (display-graphic-p))
       (insert alt)
-    (let ((image (shr-rescale-image data)))
-      (put-image image point alt))))
+    (let ((image (ignore-errors
+		   (shr-rescale-image data))))
+      (when image
+	(put-image image point alt)))))
 
 (defun shr-rescale-image (data)
   (if (or (not (fboundp 'imagemagick-types))
 	  (not (get-buffer-window (current-buffer))))
       (create-image data nil t)
     (let* ((image (create-image data nil t))
-	   (size (image-size image))
+	   (size (image-size image t))
 	   (width (car size))
 	   (height (cdr size))
 	   (edges (window-inside-pixel-edges
@@ -196,14 +213,15 @@
 		     image)))
       image)))
 
-(defun shr-pre (cont)
+(defun shr-tag-pre (cont)
   (let ((shr-folding-mode nil))
     (shr-ensure-newline)
     (shr-generic cont)
     (shr-ensure-newline)))
 
-(defun shr-blockquote (cont)
-  (shr-pre cont))
+(defun shr-tag-blockquote (cont)
+  (let ((shr-indentation (+ shr-indentation 4)))
+    (shr-tag-pre cont)))
 
 (defun shr-ensure-newline ()
   (unless (zerop (current-column))
@@ -217,19 +235,32 @@
    ((eq shr-folding-mode 'none)
     (insert t))
    (t
-    (let (column)
+    (let ((first t)
+	  column)
+      (when (and (string-match "^[ \t\n]" text)
+		 (not (bolp)))
+	(insert " "))
       (dolist (elem (split-string text))
 	(setq column (current-column))
 	(when (> column 0)
-	  (if (> (+ column (length elem) 1) shr-width)
-	      (insert "\n")
-	    (insert " ")))
+	  (cond
+	   ((> (+ column (length elem) 1) shr-width)
+	    (insert "\n"))
+	   ((not first)
+	    (insert " "))))
+	(setq first nil)
+	(when (and (bolp)
+		   (> shr-indentation 0))
+	  (insert (make-string shr-indentation ? )))
 	;; 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))))))
+	(insert elem))
+      (when (and (string-match "[ \t\n]$" text)
+		 (not (bolp)))
+	(insert " "))))))
 
 (defun shr-get-image-data (url)
   "Get image data for URL.
@@ -241,6 +272,53 @@
               (search-forward "\r\n\r\n" nil t))
       (buffer-substring (point) (point-max)))))
 
+(defvar shr-list-mode nil)
+
+(defun shr-tag-ul (cont)
+  (shr-ensure-paragraph)
+  (let ((shr-list-mode 'ul))
+    (shr-generic cont)))
+
+(defun shr-tag-ol (cont)
+  (let ((shr-list-mode 1))
+    (shr-generic cont)))
+
+(defun shr-tag-li (cont)
+  (shr-ensure-newline)
+  (if (numberp shr-list-mode)
+      (progn
+	(insert (format "%d " shr-list-mode))
+	(setq shr-list-mode (1+ shr-list-mode)))
+    (insert "* "))
+  (shr-generic cont))
+
+(defun shr-tag-br (cont)
+  (shr-ensure-newline)
+  (shr-generic cont))
+
+(defun shr-tag-h1 (cont)
+  (shr-heading cont 'bold 'underline))
+
+(defun shr-tag-h2 (cont)
+  (shr-heading cont 'bold))
+
+(defun shr-tag-h3 (cont)
+  (shr-heading cont 'italic))
+
+(defun shr-tag-h4 (cont)
+  (shr-heading cont))
+
+(defun shr-tag-h5 (cont)
+  (shr-heading cont))
+
+(defun shr-tag-h6 (cont)
+  (shr-heading cont))
+
+(defun shr-heading (cont &rest types)
+  (shr-ensure-paragraph)
+  (apply #'shr-fontize-cont cont types)
+  (shr-ensure-paragraph))
+
 (provide 'shr)
 
 ;;; shr.el ends here