Merge changes made in Gnus trunk.

shr.el: Start implementation.
shr.el: Continue implementation.
gnus-gravatar.el (gnus-gravatar-insert): Adjust character where we should go backward.
shr.el: Minimally useful state achieved.
mm-decode.el (mm-text-html-renderer): Switch to using shr.el for HTML rendering.
shr.el: (shr-insert): Add a newline after every picture before text.
gnus.texi (Splitting Mail): Really fix the @ref syntax.
shr.el (shr-add-font): Use overlays for combining faces.
shr.el (shr-add-font): Use overlays for combining faces.
shr.el (shr-insert): Pass upwards the text start point.
gnus-util.el: Reintroduce multiple completion functions.

8 files changed, 317 insertions, 26 deletions

diff --git a/doc/misc/ChangeLog b/doc/misc/ChangeLog
index 299f29166ea..0b2c79088ac 100644
--- a/doc/misc/ChangeLog
+++ b/doc/misc/ChangeLog
@@ -1,6 +1,7 @@
 2010-10-02  Lars Magne Ingebrigtsen  <larsi@gnus.org>
 
         * gnus.texi (Splitting Mail): Fix @xref syntax.
+        (Splitting Mail): Really fix the @ref syntax.
 
 2010-10-01  Lars Magne Ingebrigtsen  <larsi@gnus.org>
 
diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi
index 5431a57dc5a..00f58b2307a 100644
--- a/doc/misc/gnus.texi
+++ b/doc/misc/gnus.texi
@@ -15111,7 +15111,7 @@ message.  The function should return a list of group names that it
 thinks should carry this mail message.
 
 This variable can also be a fancy split method.  For the syntax,
-@pxref{Fancy Mail Splitting}.
+see @ref{Fancy Mail Splitting}.
 
 Note that the mail back ends are free to maul the poor, innocent,
 incoming headers all they want to.  They all add @code{Lines} headers;
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 64658bc629c..8d227906aca 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,28 @@
+2010-10-02  Julien Danjou  <julien@danjou.info>
+
+        * gnus-util.el (gnus-iswitchb-completing-read): New function.
+        (gnus-ido-completing-read): New function.
+        (gnus-emacs-completing-read): New function.
+        (gnus-completing-read): Use gnus-completing-read-function.
+        Add gnus-completing-read-function.
+
+2010-10-02  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+        * shr.el (shr-insert-document): Autoload.
+        (shr-img): Be silent.
+        (shr-insert): Add a newline after every picture before text.
+        (shr-add-font): Use overlays for combining faces.
+        (shr-insert): Pass upwards the text start point.
+
+        * mm-decode.el (mm-text-html-renderer): Default to shr.el rendering, if
+        possible.
+        (mm-shr): New function.
+
+2010-10-02  Julien Danjou  <julien@danjou.info>
+
+        * gnus-gravatar.el (gnus-gravatar-insert): Adjust character where we
+        should go backward.
+
 2010-10-02  Juanma Barranquero  <lekktu@gmail.com>
 
         * shr.el (shr): Fix typo in provide call.
diff --git a/lisp/gnus/gnus-gravatar.el b/lisp/gnus/gnus-gravatar.el
index 2af975b09c7..de373cfdf05 100644
--- a/lisp/gnus/gnus-gravatar.el
+++ b/lisp/gnus/gnus-gravatar.el
@@ -76,7 +76,7 @@ Set image category to CATEGORY."
                      (search-backward mail-address nil t)))
           (goto-char (1- (point)))
           ;; If we're on the " quoting the name, go backward
-          (when (looking-at "\"")
+          (when (looking-at "[\"<]")
             (goto-char (1- (point))))
           ;; Do not do anything if there's already a gravatar. This can
           ;; happens if the buffer has been regenerated in the mean time, for
diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el
index 0b64a237426..a6a243adc09 100644
--- a/lisp/gnus/gnus-html.el
+++ b/lisp/gnus/gnus-html.el
@@ -402,7 +402,8 @@ Return a string with image data."
 
 (defun gnus-html-put-image (data url &optional alt-text)
   (when (gnus-graphic-display-p)
-    (let* ((start (text-property-any (point-min) (point-max) 'gnus-image-url url))
+    (let* ((start (text-property-any (point-min) (point-max)
+                                     'gnus-image-url url))
            (end (when start
                   (next-single-property-change start 'gnus-image-url))))
       ;; Image found?
@@ -416,7 +417,8 @@ Return a string with image data."
                             (image-size image t)))))
           (save-excursion
             (goto-char start)
-            (let ((alt-text (or alt-text (buffer-substring-no-properties start end))))
+            (let ((alt-text (or alt-text
+                                (buffer-substring-no-properties start end))))
               (if (and image
                        ;; Kludge to avoid displaying 30x30 gif images, which
                        ;; seems to be a signal of a broken image.
@@ -424,8 +426,9 @@ Return a string with image data."
                                      (glyphp image)
                                    (listp image))
                                  (eq (if (featurep 'xemacs)
-                                         (let ((d (cdadar (specifier-spec-list
-                                                           (glyph-image image)))))
+                                         (let ((d (cdadar
+                                                   (specifier-spec-list
+                                                    (glyph-image image)))))
                                            (and (vectorp d)
                                                 (aref d 0)))
                                        (plist-get (cdr image) :type))
@@ -437,17 +440,21 @@ Return a string with image data."
                     (delete-region start end)
                     (gnus-put-image image alt-text 'external)
                     (gnus-put-text-property start (point) 'help-echo alt-text)
-                    (gnus-overlay-put (gnus-make-overlay start (point)) 'local-map
-                                      gnus-html-displayed-image-map)
-                    (gnus-put-text-property start (point) 'gnus-alt-text alt-text)
+                    (gnus-overlay-put
+                     (gnus-make-overlay start (point)) 'local-map
+                     gnus-html-displayed-image-map)
+                    (gnus-put-text-property start (point)
+                                            'gnus-alt-text alt-text)
                     (when url
-                      (gnus-put-text-property start (point) 'gnus-image-url url))
+                      (gnus-put-text-property start (point)
+                                              'gnus-image-url url))
                     (gnus-add-image 'external image)
                     t)
                 ;; Bad image, try to show something else
                 (when (fboundp 'find-image)
                   (delete-region start end)
-                  (setq image (find-image '((:type xpm :file "lock-broken.xpm"))))
+                  (setq image (find-image
+                               '((:type xpm :file "lock-broken.xpm"))))
                   (gnus-put-image image alt-text 'internal)
                   (gnus-add-image 'internal image))
                 nil))))))))
@@ -458,7 +465,8 @@ Return a string with image data."
       image
     (let* ((width (car size))
            (height (cdr size))
-           (edges (gnus-window-inside-pixel-edges (get-buffer-window (current-buffer))))
+           (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
diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el
index d188ebab734..0bf5b66a71d 100644
--- a/lisp/gnus/gnus-util.el
+++ b/lisp/gnus/gnus-util.el
@@ -44,11 +44,19 @@
     (defmacro with-no-warnings (&rest body)
       `(progn ,@body))))
 
-(defcustom gnus-use-ido nil
-  "Whether to use `ido' for `completing-read'."
+(defcustom gnus-completing-read-function 'gnus-emacs-completing-read
+  "Function use to do completing read."
   :version "24.1"
   :group 'gnus-meta
-  :type 'boolean)
+  :type '(radio (function-item
+                 :doc "Use Emacs standard `completing-read' function."
+                 gnus-emacs-completing-read)
+                (function-item
+                 :doc "Use `ido-completing-read' function."
+                 gnus-ido-completing-read)
+                (function-item
+                 :doc "Use iswitchb based completing-read function."
+                 gnus-iswitchb-completing-read)))
 
 (defcustom gnus-completion-styles
   (if (and (boundp 'completion-styles-alist)
@@ -1585,17 +1593,46 @@ SPEC is a predicate specifier that contains stuff like `or', `and',
 
 (defun gnus-completing-read (prompt collection &optional require-match
                                     initial-input history def)
-  "Call `completing-read' or `ido-completing-read'.
-Depends on `gnus-use-ido'."
+  "Call `gnus-completing-read-function'."
+  (funcall gnus-completing-read-function
+           (concat prompt (when def
+                            (concat " (default " def ")"))
+                   ": ")
+           collection require-match initial-input history def))
+
+(defun gnus-emacs-completing-read (prompt collection &optional require-match
+                                          initial-input history def)
+  "Call standard `completing-read-function'."
   (let ((completion-styles gnus-completion-styles))
-    (funcall
-     (if gnus-use-ido
-         'ido-completing-read
-       'completing-read)
-     (concat prompt (when def
-                      (concat " (default " def ")"))
-             ": ")
-     collection nil require-match initial-input history def)))
+    (completing-read prompt collection nil require-match initial-input history def)))
+
+(defun gnus-ido-completing-read (prompt collection &optional require-match
+                                        initial-input history def)
+  "Call `ido-completing-read-function'."
+  (require 'ido)
+  (ido-completing-read prompt collection nil require-match initial-input history def))
+
+(defun gnus-iswitchb-completing-read (prompt collection &optional require-match
+                                            initial-input history def)
+  "`iswitchb' based completing-read function."
+  (require 'iswitchb)
+  (let ((iswitchb-make-buflist-hook
+         (lambda ()
+           (setq iswitchb-temp-buflist
+                 (let ((choices (append
+                                 (when initial-input (list initial-input))
+                                 (symbol-value history) collection))
+                       filtered-choices)
+                   (dolist (x choices)
+                     (setq filtered-choices (adjoin x filtered-choices)))
+                   (nreverse filtered-choices))))))
+    (unwind-protect
+        (progn
+          (when (not iswitchb-mode)
+            (add-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup))
+          (iswitchb-read-buffer prompt def require-match))
+      (when (not iswitchb-mode)
+        (remove-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup)))))
 
 (defun gnus-graphic-display-p ()
   (if (featurep 'xemacs)
diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el
index 7562e57ca8f..e98d66683c9 100644
--- a/lisp/gnus/mm-decode.el
+++ b/lisp/gnus/mm-decode.el
@@ -105,7 +105,8 @@
          ,disposition ,description ,cache ,id))
 
 (defcustom mm-text-html-renderer
-  (cond ((executable-find "w3m") 'gnus-article-html)
+  (cond ((fboundp 'libxml-parse-html-region) 'mm-shr)
+        ((executable-find "w3m") 'gnus-article-html)
         ((executable-find "links") 'links)
         ((executable-find "lynx") 'lynx)
         ((locate-library "w3") 'w3)
@@ -1674,6 +1675,14 @@ If RECURSIVE, search recursively."
          (and (eq (mm-body-7-or-8) '7bit)
               (not (mm-long-lines-p 76))))))
 
+(defun mm-shr (handle)
+  (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))))))
+
 (provide 'mm-decode)
 
 ;;; mm-decode.el ends here
diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el
index c5d34b90f36..4a778b892de 100644
--- a/lisp/gnus/shr.el
+++ b/lisp/gnus/shr.el
@@ -30,6 +30,217 @@
 
 ;;; Code:
 
+(defgroup shr nil
+  "Simple HTML Renderer"
+  :group 'mail)
+
+(defcustom shr-max-image-proportion 0.9
+  "How big pictures displayed are in relation to the window they're in.
+A value of 0.7 means that they are allowed to take up 70% of the
+width and height of the window.  If they are larger than this,
+and Emacs supports it, then the images will be rescaled down to
+fit these criteria."
+  :version "24.1"
+  :group 'shr
+  :type 'float)
+
+(defcustom shr-blocked-images nil
+  "Images that have URLs matching this regexp will be blocked."
+  :version "24.1"
+  :group 'shr
+  :type 'regexp)
+
+(defvar shr-folding-mode nil)
+(defvar shr-state nil)
+(defvar shr-start nil)
+
+(defvar shr-width 70)
+
+(defun shr-transform-dom (dom)
+  (let ((result (list (pop dom))))
+    (dolist (arg (pop dom))
+      (push (cons (intern (concat ":" (symbol-name (car arg))) obarray)
+                  (cdr arg))
+            result))
+    (dolist (sub dom)
+      (if (stringp sub)
+          (push (cons :text sub) result)
+        (push (shr-transform-dom sub) result)))
+    (nreverse result)))
+
+;;;###autoload
+(defun shr-insert-document (dom)
+  (let ((shr-state nil)
+        (shr-start nil))
+    (shr-descend (shr-transform-dom dom))))
+
+(defun shr-descend (dom)
+  (let ((function (intern (concat "shr-" (symbol-name (car dom))) obarray)))
+    (if (fboundp function)
+        (funcall function (cdr dom))
+      (shr-generic (cdr dom)))))
+
+(defun shr-generic (cont)
+  (dolist (sub cont)
+    (cond
+     ((eq (car sub) :text)
+      (shr-insert (cdr sub)))
+     ((consp (cdr sub))
+      (shr-descend sub)))))
+
+(defun shr-p (cont)
+  (shr-ensure-newline)
+  (insert "\n")
+  (shr-generic cont)
+  (insert "\n"))
+
+(defun shr-b (cont)
+  (shr-fontize-cont cont 'bold))
+
+(defun shr-i (cont)
+  (shr-fontize-cont cont 'italic))
+
+(defun shr-u (cont)
+  (shr-fontize-cont cont 'underline))
+
+(defun shr-s (cont)
+  (shr-fontize-cont cont 'strikethru))
+
+(defun shr-fontize-cont (cont type)
+  (let (shr-start)
+    (shr-generic cont)
+    (shr-add-font shr-start (point) type)))
+
+(defun shr-add-font (start end type)
+  (let ((overlay (make-overlay start end)))
+    (overlay-put overlay 'face type)))
+
+(defun shr-a (cont)
+  (let ((url (cdr (assq :href cont)))
+        shr-start)
+    (shr-generic cont)
+    (widget-convert-button
+     'link shr-start (point)
+     :action 'shr-browse-url
+     :url url
+     :keymap widget-keymap
+     :help-echo url)))
+
+(defun shr-browse-url (widget &rest stuff)
+  (browse-url (widget-get widget :url)))
+
+(defun shr-img (cont)
+  (let ((start (point-marker)))
+    (let ((alt (cdr (assq :alt cont)))
+          (url (cdr (assq :src cont))))
+      (when (zerop (length alt))
+        (setq alt "[img]"))
+      (cond
+       ((and shr-blocked-images
+             (string-match shr-blocked-images url))
+        (insert alt))
+       ((url-is-cached (browse-url-url-encode-chars url "[&)$ ]"))
+        (shr-put-image (shr-get-image-data url) (point) alt))
+       (t
+        (insert alt)
+        (url-retrieve url 'shr-image-fetched
+                      (list (current-buffer) start (point-marker))
+                      t)))
+      (insert " ")
+      (setq shr-state 'image))))
+
+(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
+          (let ((alt (buffer-substring start end))
+                (inhibit-read-only t))
+            (delete-region start end)
+            (shr-put-image data start alt))))))
+  (kill-buffer (current-buffer)))
+
+(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))))
+
+(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))
+           (width (car size))
+           (height (cdr size))
+           (edges (window-inside-pixel-edges
+                   (get-buffer-window (current-buffer))))
+           (window-width (truncate (* shr-max-image-proportion
+                                      (- (nth 2 edges) (nth 0 edges)))))
+           (window-height (truncate (* shr-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 shr-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-ensure-newline ()
+  (unless (zerop (current-column))
+    (insert "\n")))
+
+(defun shr-insert (text)
+  (when (eq shr-state 'image)
+    (insert "\n")
+    (setq shr-state nil))
+  (cond
+   ((eq shr-folding-mode 'none)
+    (insert t))
+   (t
+    (let (column)
+      (dolist (elem (split-string text))
+        (setq column (current-column))
+        (when (plusp column)
+          (if (> (+ column (length elem) 1) shr-width)
+              (insert "\n")
+            (insert " ")))
+        ;; 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))))))
+
+(defun shr-get-image-data (url)
+  "Get image data for URL.
+Return a string with image data."
+  (with-temp-buffer
+    (mm-disable-multibyte)
+    (url-cache-extract (url-cache-create-filename url))
+    (when (or (search-forward "\n\n" nil t)
+              (search-forward "\r\n\r\n" nil t))
+      (buffer-substring (point) (point-max)))))
+
 (provide 'shr)
 
 ;;; shr.el ends here