Try reinstalling Paul Eggert's `gnus-button-alist' change to investigate why the...

[gnus] / lisp / message.el

diff --git a/lisp/message.el b/lisp/message.el
index 0110f8b..2bc8116 100644 (file)
--- a/lisp/message.el
+++ b/lisp/message.el
@@ -1,6 +1,6 @@
 ;;; message.el --- composing mail and news messages
 
 ;;; message.el --- composing mail and news messages
 

-;; Copyright (C) 1996-2014 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2015 Free Software Foundation, Inc.

 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: mail, news
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: mail, news


@@ -47,6 +47,7 @@
 (require 'mml)
 (require 'rfc822)
 (require 'format-spec)
 (require 'mml)
 (require 'rfc822)
 (require 'format-spec)

+(require 'dired)

 
 (autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/
 
 
 (autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/
 


@@ -626,7 +627,7 @@ This may also be a list of regexps."
   "If non-nil, delete non-matching headers when forwarding a message.
 Only headers that match this regexp will be included.  This
 variable should be a regexp or a list of regexps."
   "If non-nil, delete non-matching headers when forwarding a message.
 Only headers that match this regexp will be included.  This
 variable should be a regexp or a list of regexps."

-  :version "24.5"
+  :version "25.1"

   :group 'message-forwarding
   :type '(repeat :value-to-internal (lambda (widget value)
                                      (custom-split-regexp-maybe value))
   :group 'message-forwarding
   :type '(repeat :value-to-internal (lambda (widget value)
                                      (custom-split-regexp-maybe value))


@@ -1009,20 +1010,24 @@ configuration.  See the variable `gnus-cite-attribution-suffix'."
 (defcustom message-citation-line-format "On %a, %b %d %Y, %N wrote:\n"
   "Format of the \"Whomever writes:\" line.
 
 (defcustom message-citation-line-format "On %a, %b %d %Y, %N wrote:\n"
   "Format of the \"Whomever writes:\" line.
 

-The string is formatted using `format-spec'.  The following
-constructs are replaced:
+The string is formatted using `format-spec'.  The following constructs
+are replaced:

 
   %f   The full From, e.g. \"John Doe <john.doe@example.invalid>\".
   %n   The mail address, e.g. \"john.doe@example.invalid\".
   %N   The real name if present, e.g.: \"John Doe\", else fall
        back to the mail address.
 
   %f   The full From, e.g. \"John Doe <john.doe@example.invalid>\".
   %n   The mail address, e.g. \"john.doe@example.invalid\".
   %N   The real name if present, e.g.: \"John Doe\", else fall
        back to the mail address.

-  %F   The first name if present, e.g.: \"John\".
+  %F   The first name if present, e.g.: \"John\", else fall
+       back to the mail address.

   %L   The last name if present, e.g.: \"Doe\".
   %L   The last name if present, e.g.: \"Doe\".

+  %Z, %z   The time zone in the numeric form, e.g.:\"+0000\".

 
 All other format specifiers are passed to `format-time-string'
 
 All other format specifiers are passed to `format-time-string'

-which is called using the date from the article your replying to.
-Extracting the first (%F) and last name (%L) is done
-heuristically, so you should always check it yourself.
+which is called using the date from the article your replying to, but
+the date in the formatted string will be expressed in the author's
+time zone as much as possible.
+Extracting the first (%F) and last name (%L) is done heuristically,
+so you should always check it yourself.

 
 Please also read the note in the documentation of
 `message-citation-line-function'."
 
 Please also read the note in the documentation of
 `message-citation-line-function'."


@@ -1162,7 +1167,7 @@ e.g. using `gnus-posting-styles':
 
 (defcustom message-cite-style nil
   "*The overall style to be used when yanking cited text.
 
 (defcustom message-cite-style nil
   "*The overall style to be used when yanking cited text.

-Value is either `nil' (no variable overrides) or a let-style list
+Value is either nil (no variable overrides) or a let-style list

 of pairs (VARIABLE VALUE) that will be bound in
 `message-yank-original' to do the quoting.
 
 of pairs (VARIABLE VALUE) that will be bound in
 `message-yank-original' to do the quoting.
 


@@ -1796,13 +1801,20 @@ no, only reply back to the author."
   :type '(radio (const :format "%v  " nil)
                (string :format "FQDN: %v")))
 
   :type '(radio (const :format "%v  " nil)
                (string :format "FQDN: %v")))
 

-(defcustom message-use-idna (and (condition-case nil (require 'idna)
-                                  (file-error))
-                                (mm-coding-system-p 'utf-8)
-                                (executable-find idna-program)
-                                (string= (idna-to-ascii "räksmörgås")
-                                         "xn--rksmrgs-5wao1o")
-                                t)
+(defcustom message-use-idna
+  (and (or (mm-coding-system-p 'utf-8)
+          (condition-case nil
+              (let (mucs-ignore-version-incompatibilities)
+                (require 'un-define))
+            (error)))
+       (condition-case nil
+          (require 'idna)
+        (file-error)
+        (invalid-operation))
+       idna-program
+       (executable-find idna-program)
+       (string= (idna-to-ascii "räksmörgås") "xn--rksmrgs-5wao1o")
+       t)

   "Whether to encode non-ASCII in domain names into ASCII according to IDNA.
 GNU Libidn, and in particular the elisp package \"idna.el\" and
 the external program \"idn\", must be installed for this
   "Whether to encode non-ASCII in domain names into ASCII according to IDNA.
 GNU Libidn, and in particular the elisp package \"idna.el\" and
 the external program \"idn\", must be installed for this


@@ -1959,14 +1971,52 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'."
          "cat\\|com\\|coop\\|edu\\|gov\\|"
          "info\\|int\\|jobs\\|"
          "mil\\|mobi\\|museum\\|name\\|net\\|"
          "cat\\|com\\|coop\\|edu\\|gov\\|"
          "info\\|int\\|jobs\\|"
          "mil\\|mobi\\|museum\\|name\\|net\\|"

-         "org\\|pro\\|tel\\|travel\\|uucp\\)")
+         "org\\|pro\\|tel\\|travel\\|uucp\\|"
+          ;; ICANN-era generic top-level domains
+          "academy\\|actor\\|agency\\|airforce\\|archi\\|associates\\|axa\\|"
+          "bar\\|bargains\\|bayern\\|beer\\|berlin\\|best\\|bid\\|bike\\|"
+          "biz\\|black\\|blackfriday\\|blue\\|boutique\\|build\\|builders\\|"
+          "buzz\\|cab\\|camera\\|camp\\|capital\\|cards\\|care\\|career\\|"
+          "careers\\|cash\\|catering\\|center\\|ceo\\|cheap\\|christmas\\|"
+          "church\\|citic\\|cleaning\\|clinic\\|clothing\\|club\\|codes\\|"
+          "coffee\\|college\\|cologne\\|com\\|community\\|company\\|computer\\|"
+          "construction\\|contractors\\|cooking\\|cool\\|country\\|creditcard\\|"
+          "cruises\\|dance\\|dating\\|democrat\\|dental\\|desi\\|design\\|"
+          "diamonds\\|directory\\|discount\\|domains\\|education\\|email\\|"
+          "engineering\\|enterprises\\|equipment\\|estate\\|eus\\|events\\|"
+          "exchange\\|expert\\|exposed\\|fail\\|farm\\|feedback\\|finance\\|"
+          "financial\\|fish\\|fishing\\|fitness\\|flights\\|florist\\|foo\\|"
+          "foundation\\|frogans\\|fund\\|furniture\\|futbol\\|gal\\|"
+          "gallery\\|gift\\|glass\\|globo\\|gmo\\|gop\\|graphics\\|gratis\\|"
+          "gripe\\|guide\\|guitars\\|guru\\|hamburg\\|haus\\|hiphop\\|"
+          "holdings\\|holiday\\|homes\\|horse\\|house\\|immobilien\\|"
+          "industries\\|info\\|ink\\|institute\\|insure\\|international\\|"
+          "investments\\|jetzt\\|juegos\\|kaufen\\|kim\\|kitchen\\|kiwi\\|"
+          "koeln\\|kred\\|land\\|lat\\|latino\\|lease\\|life\\|lighting\\|"
+          "limited\\|limo\\|link\\|loans\\|london\\|luxe\\|luxury\\|"
+          "management\\|mango\\|marketing\\|media\\|meet\\|menu\\|miami\\|"
+          "moda\\|moe\\|monash\\|moscow\\|motorcycles\\|nagoya\\|name\\|"
+          "net\\|neustar\\|ninja\\|nyc\\|okinawa\\|onl\\|org\\|paris\\|"
+          "partners\\|parts\\|photo\\|photography\\|photos\\|pics\\|"
+          "pictures\\|pink\\|plumbing\\|pro\\|productions\\|properties\\|"
+          "pub\\|qpon\\|quebec\\|recipes\\|red\\|reisen\\|ren\\|rentals\\|"
+          "repair\\|report\\|rest\\|reviews\\|rich\\|rocks\\|rodeo\\|"
+          "ruhr\\|ryukyu\\|saarland\\|schule\\|scot\\|services\\|sexy\\|"
+          "shiksha\\|shoes\\|singles\\|social\\|sohu\\|solar\\|solutions\\|"
+          "soy\\|supplies\\|supply\\|support\\|surgery\\|systems\\|tattoo\\|"
+          "tax\\|technology\\|tienda\\|tips\\|today\\|tokyo\\|tools\\|"
+          "town\\|toys\\|trade\\|training\\|university\\|uno\\|vacations\\|"
+          "vegas\\|ventures\\|viajes\\|villas\\|vision\\|vodka\\|vote\\|"
+          "voting\\|voto\\|voyage\\|wang\\|watch\\|webcam\\|wed\\|wien\\|"
+          "wiki\\|works\\|wtc\\|wtf\\|xyz\\|yachts\\|yokohama\\|you\\|"
+          "zone\\)")

   ;; http://en.wikipedia.org/wiki/List_of_Internet_top-level_domains
   ;; http://en.wikipedia.org/wiki/GTLD
   ;; `approved, but not yet in operation': .xxx
   ;; "dead" nato bitnet uucp
   "Regular expression that matches a valid FQDN."
   ;; see also: gnus-button-valid-fqdn-regexp
   ;; http://en.wikipedia.org/wiki/List_of_Internet_top-level_domains
   ;; http://en.wikipedia.org/wiki/GTLD
   ;; `approved, but not yet in operation': .xxx
   ;; "dead" nato bitnet uucp
   "Regular expression that matches a valid FQDN."
   ;; see also: gnus-button-valid-fqdn-regexp

-  :version "22.1"
+  :version "25.1"

   :group 'message-headers
   :type 'regexp)
 
   :group 'message-headers
   :type 'regexp)
 


@@ -2304,7 +2354,7 @@ Leading \"Re: \" is not stripped by this function.  Use the function
                   ((not (string-match
                          (concat "^[ \t]*"
                                  (regexp-quote new-subject)
                   ((not (string-match
                          (concat "^[ \t]*"
                                  (regexp-quote new-subject)

-                                 " \t]*$")
+                                 "[ \t]*$")

                          old-subject))  ; yes, it really is a new subject
                    ;; delete eventual Re: prefix
                    (setq old-subject
                          old-subject))  ; yes, it really is a new subject
                    ;; delete eventual Re: prefix
                    (setq old-subject


@@ -2958,6 +3008,30 @@ See also `message-forbidden-properties'."
 
 (autoload 'ecomplete-setup "ecomplete") ;; for Emacs <23.
 
 
 (autoload 'ecomplete-setup "ecomplete") ;; for Emacs <23.
 

+(defvar message-smileys '(":-)" ":)"
+                          ":-(" ":("
+                          ";-)" ";)")
+  "A list of recognized smiley faces in `message-mode'.")
+
+(defun message--syntax-propertize (beg end)
+  "Syntax-propertize certain message text specially."
+  (let ((citation-regexp (concat "^" message-cite-prefix-regexp ".*$"))
+        (smiley-regexp (regexp-opt message-smileys)))
+    (goto-char beg)
+    (while (search-forward-regexp citation-regexp
+                                  end 'noerror)
+      (let ((start (match-beginning 0))
+            (end (match-end 0)))
+        (add-text-properties start (1+ start)
+                             `(syntax-table ,(string-to-syntax "<")))
+        (add-text-properties end (min (1+ end) (point-max))
+                             `(syntax-table ,(string-to-syntax ">")))))
+    (goto-char beg)
+    (while (search-forward-regexp smiley-regexp
+            end 'noerror)
+      (add-text-properties (match-beginning 0) (match-end 0)
+                           `(syntax-table ,(string-to-syntax "."))))))
+

 ;;;###autoload
 (define-derived-mode message-mode text-mode "Message"
   "Major mode for editing mail and news to be sent.
 ;;;###autoload
 (define-derived-mode message-mode text-mode "Message"
   "Major mode for editing mail and news to be sent.


@@ -3060,7 +3134,13 @@ M-RET    `message-newline-and-reformat' (break the line and reformat)."
     ;; multibyte is not necessary at all. -- zsh
     (mm-enable-multibyte))
   (set (make-local-variable 'indent-tabs-mode) nil) ;No tabs for indentation.
     ;; multibyte is not necessary at all. -- zsh
     (mm-enable-multibyte))
   (set (make-local-variable 'indent-tabs-mode) nil) ;No tabs for indentation.

-  (mml-mode))
+  (mml-mode)
+  ;; Syntactic fontification. Helps `show-paren-mode',
+  ;; `electric-pair-mode', and C-M-* navigation by syntactically
+  ;; excluding citations and other artifacts.
+  ;;
+  (set (make-local-variable 'syntax-propertize-function) 'message--syntax-propertize)
+  (set (make-local-variable 'parse-sexp-ignore-comments) t))

 
 (defun message-setup-fill-variables ()
   "Setup message fill variables."
 
 (defun message-setup-fill-variables ()
   "Setup message fill variables."


@@ -3571,15 +3651,16 @@ Message buffers and is not meant to be called directly."
       (goto-char (point-max))
       ;; Insert the signature.
       (unless (bolp)
       (goto-char (point-max))
       ;; Insert the signature.
       (unless (bolp)

-       (insert "\n"))
+       (newline))

       (when message-signature-insert-empty-line
       (when message-signature-insert-empty-line

-       (insert "\n"))
-      (insert "-- \n")
+       (newline))
+      (insert "-- ")
+      (newline)

       (if (eq signature t)
          (insert-file-contents signature-file)
        (insert signature))
       (goto-char (point-max))
       (if (eq signature t)
          (insert-file-contents signature-file)
        (insert signature))
       (goto-char (point-max))

-      (or (bolp) (insert "\n")))))
+      (or (bolp) (newline)))))

 
 (defun message-insert-importance-high ()
   "Insert header to mark message as important."
 
 (defun message-insert-importance-high ()
   "Insert header to mark message as important."


@@ -3960,12 +4041,14 @@ This function uses `mail-citation-hook' if that is non-nil."
   "Cite function in the standard Message manner."
   (message-cite-original-1 nil))
 
   "Cite function in the standard Message manner."
   (message-cite-original-1 nil))
 

-(defvar gnus-extract-address-components)
-

 (autoload 'format-spec "format-spec")
 (autoload 'format-spec "format-spec")

+(autoload 'gnus-date-get-time "gnus-util")

 
 

-(defun message-insert-formatted-citation-line (&optional from date)
+(defun message-insert-formatted-citation-line (&optional from date tz)

   "Function that inserts a formatted citation line.
   "Function that inserts a formatted citation line.

+The optional FROM, and DATE are strings containing the contents of
+the From header and the Date header respectively.  The optional TZ
+is a number of seconds, overrides the time zone of DATE.

 
 See `message-citation-line-format'."
   ;; The optional args are for testing/debugging.  They will disappear later.
 
 See `message-citation-line-format'."
   ;; The optional args are for testing/debugging.  They will disappear later.


@@ -3973,13 +4056,13 @@ See `message-citation-line-format'."
   ;; (with-temp-buffer
   ;;   (message-insert-formatted-citation-line
   ;;    "John Doe <john.doe@example.invalid>"
   ;; (with-temp-buffer
   ;;   (message-insert-formatted-citation-line
   ;;    "John Doe <john.doe@example.invalid>"

-  ;;    (current-time))
+  ;;    (message-make-date))

   ;;   (buffer-string))
   (when (or message-reply-headers (and from date))
     (unless from
       (setq from (mail-header-from message-reply-headers)))
     (let* ((data (condition-case ()
   ;;   (buffer-string))
   (when (or message-reply-headers (and from date))
     (unless from
       (setq from (mail-header-from message-reply-headers)))
     (let* ((data (condition-case ()

-                    (funcall (if (boundp gnus-extract-address-components)
+                    (funcall (if (boundp 'gnus-extract-address-components)

                                  gnus-extract-address-components
                                'mail-extract-address-components)
                              from)
                                  gnus-extract-address-components
                                'mail-extract-address-components)
                              from)


@@ -3990,34 +4073,49 @@ See `message-citation-line-format'."
           (net (car (cdr data)))
           (name-or-net (or (car data)
                            (car (cdr data)) from))
           (net (car (cdr data)))
           (name-or-net (or (car data)
                            (car (cdr data)) from))

-          (replydate
-           (or
-            date
-            ;; We need Gnus functionality if the user wants date or time from
-            ;; the original article:
-            (when (string-match "%[^fnNFL]" message-citation-line-format)
-              (autoload 'gnus-date-get-time "gnus-util")
-              (gnus-date-get-time (mail-header-date message-reply-headers)))))
+          (time
+           (when (string-match "%[^fnNFL]" message-citation-line-format)
+             (cond ((numberp (car-safe date)) date) ;; backward compatibility
+                   (date (gnus-date-get-time date))
+                   (t
+                    (gnus-date-get-time
+                     (setq date (mail-header-date message-reply-headers)))))))
+          (tz (or tz
+                  (when (stringp date)
+                    (nth 8 (parse-time-string date)))))

           (flist
            (let ((i ?A) lst)
              (when (stringp name)
                ;; Guess first name and last name:
           (flist
            (let ((i ?A) lst)
              (when (stringp name)
                ;; Guess first name and last name:

-                (let* ((names (delq nil (mapcar (lambda (x)
-                                                 (if (string-match "\\`\\(\\w\\|[-.]\\)+\\'" x) x nil))
-                                               (split-string name "[ \t]+"))))
-                      (count (length names)))
-                  (cond ((= count 1) (setq fname (car names)
-                                           lname ""))
-                        ((or (= count 2) (= count 3)) (setq fname (car names)
-                                                            lname (mapconcat 'identity (cdr names) " ")))
-                        ((> count 3) (setq fname (mapconcat 'identity (butlast names (- count 2)) " ")
-                                           lname (mapconcat 'identity (nthcdr 2 names) " "))) )
+               (let* ((names (delq
+                              nil
+                              (mapcar
+                               (lambda (x)
+                                 (if (string-match "\\`\\(\\w\\|[-.]\\)+\\'"
+                                                   x)
+                                     x
+                                   nil))
+                               (split-string name "[ \t]+"))))
+                      (count (length names)))
+                 (cond ((= count 1)
+                        (setq fname (car names)
+                              lname ""))
+                       ((or (= count 2) (= count 3))
+                        (setq fname (car names)
+                              lname (mapconcat 'identity (cdr names) " ")))
+                       ((> count 3)
+                        (setq fname (mapconcat 'identity
+                                               (butlast names (- count 2))
+                                               " ")
+                              lname (mapconcat 'identity
+                                               (nthcdr 2 names)
+                                               " "))))

                   (when (string-match "\\(.*\\),\\'" fname)
                     (let ((newlname (match-string 1 fname)))
                       (setq fname lname lname newlname)))))
              ;; The following letters are not used in `format-time-string':
              (push ?E lst) (push "<E>" lst)
                   (when (string-match "\\(.*\\),\\'" fname)
                     (let ((newlname (match-string 1 fname)))
                       (setq fname lname lname newlname)))))
              ;; The following letters are not used in `format-time-string':
              (push ?E lst) (push "<E>" lst)

-             (push ?F lst) (push fname lst)
+             (push ?F lst) (push (or fname name-or-net) lst)

              ;; We might want to use "" instead of "<X>" later.
              (push ?J lst) (push "<J>" lst)
              (push ?K lst) (push "<K>" lst)
              ;; We might want to use "" instead of "<X>" later.
              (push ?J lst) (push "<J>" lst)
              (push ?K lst) (push "<K>" lst)


@@ -4041,7 +4139,7 @@ See `message-citation-line-format'."
                               (>= i ?a)))
                  (push i lst)
                  (push (condition-case nil
                               (>= i ?a)))
                  (push i lst)
                  (push (condition-case nil

-                           (format-time-string (format "%%%c" i) replydate)
+                           (gmm-format-time-string (format "%%%c" i) time tz)

                          (error (format ">%c<" i)))
                        lst))
                (setq i (1+ i)))
                          (error (format ">%c<" i)))
                        lst))
                (setq i (1+ i)))


@@ -4884,6 +4982,11 @@ evaluates `message-send-mail-hook' just before sending a message.
 It is useful if your ISP requires the POP-before-SMTP
 authentication.  See the Gnus manual for details."
   (run-hooks 'message-send-mail-hook)
 It is useful if your ISP requires the POP-before-SMTP
 authentication.  See the Gnus manual for details."
   (run-hooks 'message-send-mail-hook)

+  ;; Change header-delimiter to be what smtpmail expects.
+  (goto-char (point-min))
+  (when (re-search-forward
+        (concat "^" (regexp-quote mail-header-separator) "\n"))
+    (replace-match "\n"))

   (smtpmail-send-it))
 
 (defun message-send-mail-with-mailclient ()
   (smtpmail-send-it))
 
 (defun message-send-mail-with-mailclient ()


@@ -5570,7 +5673,7 @@ If NOW, use that time instead."
   "Make date string for the Expires header.  Expiry in DAYS days.
 
 In posting styles use `(\"Expires\" (make-expires-date 30))'."
   "Make date string for the Expires header.  Expiry in DAYS days.
 
 In posting styles use `(\"Expires\" (make-expires-date 30))'."

-  (let* ((cur (decode-time (current-time)))
+  (let* ((cur (decode-time))

         (nday (+ days (nth 3 cur))))
     (setf (nth 3 cur) nday)
     (message-make-date (apply 'encode-time cur))))
         (nday (+ days (nth 3 cur))))
     (setf (nth 3 cur) nday)
     (message-make-date (apply 'encode-time cur))))


@@ -5827,7 +5930,7 @@ give as trustworthy answer as possible."
 
 (defun message-make-fqdn ()
   "Return user's fully qualified domain name."
 
 (defun message-make-fqdn ()
   "Return user's fully qualified domain name."

-  (let* ((system-name (system-name))
+  (let* ((sysname (system-name))

         (user-mail (message-user-mail-address))
         (user-domain
          (if (and user-mail
         (user-mail (message-user-mail-address))
         (user-domain
          (if (and user-mail


@@ -5841,10 +5944,10 @@ give as trustworthy answer as possible."
           (not (string-match message-bogus-system-names message-user-fqdn)))
       ;; `message-user-fqdn' seems to be valid
       message-user-fqdn)
           (not (string-match message-bogus-system-names message-user-fqdn)))
       ;; `message-user-fqdn' seems to be valid
       message-user-fqdn)

-     ((and (string-match message-valid-fqdn-regexp system-name)
-          (not (string-match message-bogus-system-names system-name)))
+     ((and (string-match message-valid-fqdn-regexp sysname)
+          (not (string-match message-bogus-system-names sysname)))

       ;; `system-name' returned the right result.
       ;; `system-name' returned the right result.

-      system-name)
+      sysname)

      ;; Try `mail-host-address'.
      ((and (boundp 'mail-host-address)
           (stringp mail-host-address)
      ;; Try `mail-host-address'.
      ((and (boundp 'mail-host-address)
           (stringp mail-host-address)


@@ -5859,7 +5962,7 @@ give as trustworthy answer as possible."
       user-domain)
      ;; Default to this bogus thing.
      (t
       user-domain)
      ;; Default to this bogus thing.
      (t

-      (concat system-name
+      (concat sysname

              ".i-did-not-set--mail-host-address--so-tickle-me")))))
 
 (defun message-make-domain ()
              ".i-did-not-set--mail-host-address--so-tickle-me")))))
 
 (defun message-make-domain ()


@@ -8485,6 +8588,17 @@ Used in `message-simplify-recipients'."
         (message-fetch-field hdr) t))
       ", "))))
 
         (message-fetch-field hdr) t))
       ", "))))
 

+;;; multipart/related and HTML support.
+
+(defun message-make-html-message-with-image-files (files)
+  (interactive (list (dired-get-marked-files nil current-prefix-arg)))
+  (message-mail)
+  (message-goto-body)
+  (insert "<#part type=text/html>\n\n")
+  (dolist (file files)
+    (insert (format "<img src=%S>\n\n" file)))
+  (message-goto-to))
+

 (when (featurep 'xemacs)
   (require 'messagexmas)
   (message-xmas-redefine))
 (when (featurep 'xemacs)
   (require 'messagexmas)
   (message-xmas-redefine))