;;; mml.el --- A package for parsing and validating MML documents
-;; Copyright (C) 1998-2012 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
;;; 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'
((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")
(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
(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))))
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))
(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
(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
'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.
(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.
(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)
(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"