X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fmml.el;h=575447585975d41e7a3cdfbdca161e953d6944bf;hb=91bfdfbc3e77a244efc8af47a47b30b10f48ec87;hp=43e86cb6c34b1d2686071b523d3f6e09e0c8825c;hpb=ff79efac756f360c9a48b292b4619699fe19d057;p=gnus diff --git a/lisp/mml.el b/lisp/mml.el index 43e86cb6c..575447585 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -1,7 +1,6 @@ ;;; mml.el --- A package for parsing and validating MML documents -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, -;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1998-2015 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. @@ -23,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' @@ -128,6 +124,14 @@ It is necessary to work against a bug in certain clients." :type 'boolean :group 'message) +(defcustom mml-enable-flowed t + "If non-nil, enable format=flowed usage when encoding a message. +This is only performed when filling on text/plain with hard +newlines in the text." + :version "24.1" + :type 'boolean + :group 'message) + (defvar mml-tweak-type-alist nil "A list of (TYPE . FUNCTION) for tweaking MML parts. TYPE is a string containing a regexp to match the MIME type. FUNCTION @@ -253,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") @@ -454,20 +460,82 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (defvar mml-boundary nil) (defvar mml-base-boundary "-=-=") (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 () - "Generate a MIME message based on the current MML document." +(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 +be \"related\" or \"alternate\"." (let ((cont (mml-parse)) - (mml-multipart-number mml-multipart-number)) + (mml-multipart-number mml-multipart-number) + (options message-options)) (if (not cont) nil - (mm-with-multibyte-buffer - (if (and (consp (car cont)) - (= (length cont) 1)) - (mml-generate-mime-1 (car cont)) - (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed")) - cont))) - (buffer-string))))) + (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) + (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)))) + (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 ""))))))) + cont)))) (defun mml-generate-mime-1 (cont) (let ((mm-use-ultra-safe-encoding @@ -517,7 +585,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." ;; Remove quotes from quoted tags. (goto-char (point-min)) (while (re-search-forward - "<#!+/?\\(part\\|multipart\\|external\\|mml\\)" + "<#!+/?\\(part\\|multipart\\|external\\|mml\\|secure\\)" nil t) (delete-region (+ (match-beginning 0) 2) (+ (match-beginning 0) 3)))))) @@ -532,7 +600,8 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (mml-to-mime) ;; Update handle so mml-compute-boundary can ;; detect collisions with the nested parts. - (setcdr (assoc 'contents cont) (buffer-string))) + (unless mml-inhibit-compute-boundary + (setcdr (assoc 'contents cont) (buffer-string)))) (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b"))) ;; ignore 0x1b, it is part of iso-2022-jp (setq encoding (mm-body-7-or-8)))) @@ -546,7 +615,8 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." ;; in the mml tag or it says "flowed" and there ;; actually are hard newlines in the text. (let (use-hard-newlines) - (when (and (string= type "text/plain") + (when (and mml-enable-flowed + (string= type "text/plain") (not (string= (cdr (assq 'sign cont)) "pgp")) (or (null (assq 'format cont)) (string= (cdr (assq 'format cont)) @@ -702,34 +772,30 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." "Return a unique boundary that does not exist in CONT." (let ((mml-boundary (funcall mml-boundary-function (incf mml-multipart-number)))) - ;; This function tries again and again until it has found - ;; a unique boundary. - (while (not (catch 'not-unique - (mml-compute-boundary-1 cont)))) + (unless mml-inhibit-compute-boundary + ;; This function tries again and again until it has found + ;; a unique boundary. + (while (not (catch 'not-unique + (mml-compute-boundary-1 cont))))) mml-boundary)) (defun mml-compute-boundary-1 (cont) - (let (filename) - (cond - ((member (car cont) '(part mml)) - (with-temp-buffer - (cond - ((cdr (assq 'buffer cont)) - (insert-buffer-substring (cdr (assq 'buffer cont)))) - ((and (setq filename (cdr (assq 'filename cont))) - (not (equal (cdr (assq 'nofile cont)) "yes"))) - (mm-insert-file-contents filename nil nil nil nil t)) - (t - (insert (cdr (assq 'contents cont))))) - (goto-char (point-min)) - (when (re-search-forward (concat "^--" (regexp-quote mml-boundary)) - nil t) - (setq mml-boundary (funcall mml-boundary-function - (incf mml-multipart-number))) - (throw 'not-unique nil)))) - ((eq (car cont) 'multipart) - (mapc 'mml-compute-boundary-1 (cddr cont)))) - t)) + (cond + ((member (car cont) '(part mml)) + (mm-with-multibyte-buffer + (let ((mml-inhibit-compute-boundary t) + (mml-multipart-number 0) + mml-sign-alist mml-encrypt-alist) + (mml-generate-mime-1 cont)) + (goto-char (point-min)) + (when (re-search-forward (concat "^--" (regexp-quote mml-boundary)) + nil t) + (setq mml-boundary (funcall mml-boundary-function + (incf mml-multipart-number))) + (throw 'not-unique nil)))) + ((eq (car cont) 'multipart) + (mapc 'mml-compute-boundary-1 (cddr cont)))) + t) (defun mml-make-boundary (number) (concat (make-string (% number 60) ?=) @@ -889,6 +955,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (autoload 'message-encode-message-body "message") (declare-function message-narrow-to-headers-or-head "message" ()) +;;;###autoload (defun mml-to-mime () "Translate the current buffer from MML to MIME." ;; `message-encode-message-body' will insert an encoded Content-Description @@ -1197,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)) @@ -1225,7 +1292,7 @@ If not set, `default-directory' will be used." (goto-char (point-min)) ;; Quote parts. (while (re-search-forward - "<#!*/?\\(multipart\\|part\\|external\\|mml\\)" nil t) + "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)" nil t) ;; Insert ! after the #. (goto-char (+ (match-beginning 0) 2)) (insert "!"))))) @@ -1286,10 +1353,12 @@ to specify options." :version "22.1" ;; Gnus 5.10.9 :group 'message) +;;;###autoload (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 @@ -1303,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 @@ -1315,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. @@ -1356,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. @@ -1381,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) @@ -1406,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" @@ -1446,7 +1528,7 @@ Should be adopted if code in `message-send-mail' is changed." "Display current buffer with Gnus, in a new buffer. If RAW, display a raw encoded MIME message. -The window layout for the preview buffer is controled by the variables +The window layout for the preview buffer is controlled by the variables `special-display-buffer-names', `special-display-regexps', or `gnus-buffer-configuration' (the first match made will be used), or the `pop-to-buffer' function." @@ -1457,6 +1539,7 @@ or the `pop-to-buffer' function." (require 'gnus-msg) ; for gnus-setup-posting-charset (save-excursion (let* ((buf (current-buffer)) + (article-editing (eq major-mode 'gnus-article-edit-mode)) (message-options message-options) (message-this-is-mail (message-mail-p)) (message-this-is-news (message-news-p)) @@ -1476,15 +1559,19 @@ or the `pop-to-buffer' function." (mml-preview-insert-mail-followup-to) (let ((message-deletable-headers (if (message-news-p) nil - message-deletable-headers))) + message-deletable-headers)) + (mail-header-separator (if article-editing + "" + mail-header-separator))) (message-generate-headers (copy-sequence (if (message-news-p) message-required-news-headers - message-required-mail-headers)))) - (if (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n") nil t) - (replace-match "\n")) - (let ((mail-header-separator ""));; mail-header-separator is removed. + message-required-mail-headers))) + (unless article-editing + (if (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n") nil t) + (replace-match "\n")) + (setq mail-header-separator "")) (message-sort-headers) (mml-to-mime)) (if raw @@ -1495,7 +1582,8 @@ or the `pop-to-buffer' function." (mm-disable-multibyte) (insert s))) (let ((gnus-newsgroup-charset (car message-posting-charset)) - gnus-article-prepare-hook gnus-original-article-buffer) + gnus-article-prepare-hook gnus-original-article-buffer + gnus-displaying-mime) (run-hooks 'gnus-article-decode-hook) (let ((gnus-newsgroup-name "dummy") (gnus-newsrc-hashtb (or gnus-newsrc-hashtb