X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmml.el;h=575447585975d41e7a3cdfbdca161e953d6944bf;hp=cc1aedf1b978294ba1f03f5dc545a6faea328234;hb=91bfdfbc3e77a244efc8af47a47b30b10f48ec87;hpb=23d20f6e231ff0940f0f65f74b9f9666b2989ebe

diff --git a/lisp/mml.el b/lisp/mml.el
index cc1aedf1b..575447585 100644
--- a/lisp/mml.el
+++ b/lisp/mml.el
@@ -1,6 +1,6 @@
 ;;; mml.el --- A package for parsing and validating MML documents
 
-;; Copyright (C) 1998-2012  Free Software Foundation, Inc.
+;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; This file is part of GNU Emacs.
@@ -22,16 +22,13 @@
 
 ;;; Code:
 
-;; For Emacs <22.2 and XEmacs.
-(eval-and-compile
-  (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
-
 (require 'mm-util)
 (require 'mm-bodies)
 (require 'mm-encode)
 (require 'mm-decode)
 (require 'mml-sec)
 (eval-when-compile (require 'cl))
+(eval-when-compile (require 'url))
 (eval-when-compile
   (when (featurep 'xemacs)
     (require 'easy-mmode))) ; for `define-minor-mode'
@@ -260,7 +257,9 @@ part.  This is for the internal use, you should never modify the value.")
 		((string= mode "encrypt")
 		 (setq tags (list "encrypt" method)))
 		((string= mode "signencrypt")
-		 (setq tags (list "sign" method "encrypt" method))))
+		 (setq tags (list "sign" method "encrypt" method)))
+		(t
+		 (error "Unknown secure mode %s" mode)))
 	  (eval `(mml-insert-tag ,secure-mode
 				 ,@tags
 				 ,(if keyfile "keyfile")
@@ -463,6 +462,9 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
 (defvar mml-multipart-number 0)
 (defvar mml-inhibit-compute-boundary nil)
 
+(declare-function libxml-parse-html-region "xml.c"
+		  (start end &optional base-url discard-comments))
+
 (defun mml-generate-mime (&optional multipart-type)
   "Generate a MIME message based on the current MML document.
 MULTIPART-TYPE defaults to \"mixed\", but can also
@@ -472,19 +474,69 @@ be \"related\" or \"alternate\"."
 	(options message-options))
     (if (not cont)
 	nil
+      (when (and (consp (car cont))
+		 (= (length cont) 1)
+		 (fboundp 'libxml-parse-html-region)
+		 (equal (cdr (assq 'type (car cont))) "text/html"))
+	(setq cont (mml-expand-html-into-multipart-related (car cont))))
       (prog1
 	  (mm-with-multibyte-buffer
 	    (setq message-options options)
-	    (if (and (consp (car cont))
-		     (= (length cont) 1))
-		(mml-generate-mime-1 (car cont))
+	    (cond
+	     ((and (consp (car cont))
+		   (= (length cont) 1))
+	      (mml-generate-mime-1 (car cont)))
+	     ((eq (car cont) 'multipart)
+	      (mml-generate-mime-1 cont))
+	     (t
 	      (mml-generate-mime-1
 	       (nconc (list 'multipart (cons 'type (or multipart-type "mixed")))
-		      cont)))
+		      cont))))
 	    (setq options message-options)
 	    (buffer-string))
 	(setq message-options options)))))
 
+(defun mml-expand-html-into-multipart-related (cont)
+  (let ((new-parts nil)
+	(cid 1))
+    (mm-with-multibyte-buffer
+      (insert (cdr (assq 'contents cont)))
+      (goto-char (point-min))
+      (with-syntax-table mml-syntax-table
+	(while (re-search-forward "<img\\b" nil t)
+	  (goto-char (match-beginning 0))
+	  (let* ((start (point))
+		 (img (nth 2
+			   (nth 2
+				(libxml-parse-html-region
+				 (point) (progn (forward-sexp) (point))))))
+		 (end (point))
+		 (parsed (url-generic-parse-url (cdr (assq 'src (cadr img))))))
+	    (when (and (null (url-type parsed))
+		       (url-filename parsed)
+		       (file-exists-p (url-filename parsed)))
+	      (goto-char start)
+	      (when (search-forward (url-filename parsed) end t)
+		(let ((cid (format "fsf.%d" cid)))
+		  (replace-match (concat "cid:" cid) t t)
+		  (push (list cid (url-filename parsed)) new-parts))
+		(setq cid (1+ cid)))))))
+      ;; We have local images that we want to include.
+      (if (not new-parts)
+	  (list cont)
+	(setcdr (assq 'contents cont) (buffer-string))
+	(setq cont
+	      (nconc (list 'multipart (cons 'type "related"))
+		     (list cont)))
+	(dolist (new-part (nreverse new-parts))
+	  (setq cont
+		(nconc cont
+		       (list `(part (type . "image/png")
+				    (filename . ,(nth 1 new-part))
+				    (id . ,(concat "<" (nth 0 new-part)
+						   ">")))))))
+	cont))))
+
 (defun mml-generate-mime-1 (cont)
   (let ((mm-use-ultra-safe-encoding
 	 (or mm-use-ultra-safe-encoding (assq 'sign cont))))
@@ -1212,8 +1264,8 @@ If not set, `default-directory' will be used."
 	string
       default)))
 
-(defun mml-minibuffer-read-description ()
-  (let ((description (read-string "One line description: ")))
+(defun mml-minibuffer-read-description (&optional default)
+  (let ((description (read-string "One line description: " default)))
     (when (string-match "\\`[ \t]*\\'" description)
       (setq description nil))
     description))
@@ -1305,7 +1357,8 @@ to specify options."
 (defun mml-attach-file (file &optional type description disposition)
   "Attach a file to the outgoing MIME message.
 The file is not inserted or encoded until you send the message with
-`\\[message-send-and-exit]' or `\\[message-send]'.
+`\\[message-send-and-exit]' or `\\[message-send]' in Message mode,
+or `\\[mail-send-and-exit]' or `\\[mail-send]' in Mail mode.
 
 FILE is the name of the file to attach.  TYPE is its
 content-type, a string of the form \"type/subtype\".  DESCRIPTION
@@ -1319,11 +1372,9 @@ body) or \"attachment\" (separate from the body)."
 	  (description (mml-minibuffer-read-description))
 	  (disposition (mml-minibuffer-read-disposition type nil file)))
      (list file type description disposition)))
-  ;; Don't move point if this command is invoked inside the message header.
-  (let ((head (unless (message-in-body-p)
-		(prog1
-		    (point)
-		  (goto-char (point-max))))))
+  ;; If in the message header, attach at the end and leave point unchanged.
+  (let ((head (unless (message-in-body-p) (point))))
+    (if head (goto-char (point-max)))
     (mml-insert-empty-tag 'part
 			  'type type
 			  ;; icicles redefines read-file-name and returns a
@@ -1331,12 +1382,15 @@ body) or \"attachment\" (separate from the body)."
 			  'filename (mm-substring-no-properties file)
 			  'disposition (or disposition "attachment")
 			  'description description)
+    ;; When using Mail mode, make sure it does the mime encoding
+    ;; when you send the message.
+    (or (eq mail-user-agent 'message-user-agent)
+	(setq mail-encode-mml t))
     (when head
-      (unless (prog1
-		  (pos-visible-in-window-p)
-		(goto-char head))
+      (unless (pos-visible-in-window-p)
 	(message "The file \"%s\" has been attached at the end of the message"
-		 (file-name-nondirectory file))))))
+		 (file-name-nondirectory file)))
+      (goto-char head))))
 
 (defun mml-dnd-attach-file (uri action)
   "Attach a drag and drop file.
@@ -1372,21 +1426,22 @@ BUFFER is the name of the buffer to attach.  See
 	  (description (mml-minibuffer-read-description))
 	  (disposition (mml-minibuffer-read-disposition type nil)))
      (list buffer type description disposition)))
-  ;; Don't move point if this command is invoked inside the message header.
-  (let ((head (unless (message-in-body-p)
-		(prog1
-		    (point)
-		  (goto-char (point-max))))))
+  ;; If in the message header, attach at the end and leave point unchanged.
+  (let ((head (unless (message-in-body-p) (point))))
+    (if head (goto-char (point-max)))
     (mml-insert-empty-tag 'part 'type type 'buffer buffer
 			  'disposition disposition
 			  'description description)
+    ;; When using Mail mode, make sure it does the mime encoding
+    ;; when you send the message.
+    (or (eq mail-user-agent 'message-user-agent)
+	(setq mail-encode-mml t))
     (when head
-      (unless (prog1
-		  (pos-visible-in-window-p)
-		(goto-char head))
+      (unless (pos-visible-in-window-p)
 	(message
 	 "The buffer \"%s\" has been attached at the end of the message"
-	 buffer)))))
+	 buffer))
+      (goto-char head))))
 
 (defun mml-attach-external (file &optional type description)
   "Attach an external file into the buffer.
@@ -1397,19 +1452,20 @@ TYPE is the MIME type to use."
 	  (type (mml-minibuffer-read-type file))
 	  (description (mml-minibuffer-read-description)))
      (list file type description)))
-  ;; Don't move point if this command is invoked inside the message header.
-  (let ((head (unless (message-in-body-p)
-		(prog1
-		    (point)
-		  (goto-char (point-max))))))
+  ;; If in the message header, attach at the end and leave point unchanged.
+  (let ((head (unless (message-in-body-p) (point))))
+    (if head (goto-char (point-max)))
     (mml-insert-empty-tag 'external 'type type 'name file
 			  'disposition "attachment" 'description description)
+    ;; When using Mail mode, make sure it does the mime encoding
+    ;; when you send the message.
+    (or (eq mail-user-agent 'message-user-agent)
+	(setq mail-encode-mml t))
     (when head
-      (unless (prog1
-		  (pos-visible-in-window-p)
-		(goto-char head))
+      (unless (pos-visible-in-window-p)
 	(message "The file \"%s\" has been attached at the end of the message"
-		 (file-name-nondirectory file))))))
+		 (file-name-nondirectory file)))
+      (goto-char head))))
 
 (defun mml-insert-multipart (&optional type)
   (interactive (if (message-in-body-p)
@@ -1422,13 +1478,23 @@ TYPE is the MIME type to use."
   (or type
       (setq type "mixed"))
   (mml-insert-empty-tag "multipart" 'type type)
+  ;; When using Mail mode, make sure it does the mime encoding
+  ;; when you send the message.
+  (or (eq mail-user-agent 'message-user-agent)
+      (setq mail-encode-mml t))
   (forward-line -1))
 
 (defun mml-insert-part (&optional type)
   (interactive (if (message-in-body-p)
 		   (list (mml-minibuffer-read-type ""))
 		 (error "Use this command in the message body")))
-  (mml-insert-tag 'part 'type type 'disposition "inline"))
+  ;; When using Mail mode, make sure it does the mime encoding
+  ;; when you send the message.
+  (or (eq mail-user-agent 'message-user-agent)
+      (setq mail-encode-mml t))
+  (mml-insert-tag 'part 'type type 'disposition "inline")
+  (save-excursion
+    (mml-insert-tag '/part)))
 
 (declare-function message-subscribed-p "message" ())
 (declare-function message-make-mail-followup-to "message"