X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmml.el;h=15b1bb7096ba77e63c074cdab7d9f5f6c48b5f21;hb=c9a393eeb329a99695566342a9f03b8a30000898;hp=cf592acdf69c6bf016743f270402a585157dd012;hpb=bb3d57f547bdd5f29d36b7a506dec44ac8aea51e;p=gnus diff --git a/lisp/mml.el b/lisp/mml.el index cf592acdf..15b1bb709 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -1,25 +1,23 @@ ;;; mml.el --- A package for parsing and validating MML documents -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -35,17 +33,19 @@ (require 'mm-decode) (require 'mml-sec) (eval-when-compile (require 'cl)) - -(eval-and-compile - (autoload 'message-make-message-id "message") - (autoload 'gnus-setup-posting-charset "gnus-msg") - (autoload 'gnus-make-local-hook "gnus-util") - (autoload 'message-fetch-field "message") - (autoload 'message-mark-active-p "message") - (autoload 'message-info "message") - (autoload 'fill-flowed-encode "flow-fill") - (autoload 'message-posting-charset "message") - (autoload 'dnd-get-local-file-name "dnd")) +(eval-when-compile + (when (featurep 'xemacs) + (require 'easy-mmode))) ; for `define-minor-mode' + +(autoload 'message-make-message-id "message") +(declare-function gnus-setup-posting-charset "gnus-msg" (group)) +(autoload 'gnus-make-local-hook "gnus-util") +(autoload 'message-fetch-field "message") +(autoload 'message-mark-active-p "message") +(autoload 'message-info "message") +(autoload 'fill-flowed-encode "flow-fill") +(autoload 'message-posting-charset "message") +(autoload 'dnd-get-local-file-name "dnd") (autoload 'message-options-set "message") (autoload 'message-narrow-to-head "message") @@ -120,10 +120,10 @@ match found will be used." ,dispositions)))) :group 'message) -(defcustom mml-insert-mime-headers-always nil +(defcustom mml-insert-mime-headers-always t "If non-nil, always put Content-Type: text/plain at top of empty parts. It is necessary to work against a bug in certain clients." - :version "22.1" + :version "24.1" :type 'boolean :group 'message) @@ -228,7 +228,10 @@ part. This is for the internal use, you should never modify the value.") (let* (secure-mode (taginfo (mml-read-tag)) (keyfile (cdr (assq 'keyfile taginfo))) - (certfile (cdr (assq 'certfile taginfo))) + (certfiles (delq nil (mapcar (lambda (tag) + (if (eq (car-safe tag) 'certfile) + (cdr tag))) + taginfo))) (recipients (cdr (assq 'recipients taginfo))) (sender (cdr (assq 'sender taginfo))) (location (cdr (assq 'tag-location taginfo))) @@ -254,8 +257,10 @@ part. This is for the internal use, you should never modify the value.") ,@tags ,(if keyfile "keyfile") ,keyfile - ,(if certfile "certfile") - ,certfile + ,@(apply #'append + (mapcar (lambda (certfile) + (list "certfile" certfile)) + certfiles)) ,(if recipients "recipients") ,recipients ,(if sender "sender") @@ -395,8 +400,8 @@ A message part needs to be split into %d charset parts. Really send? " (skip-chars-forward "= \t\n") (setq val (buffer-substring-no-properties (point) (progn (forward-sexp 1) (point)))) - (when (string-match "^\"\\(.*\\)\"$" val) - (setq val (match-string 1 val))) + (when (string-match "\\`\"" val) + (setq val (read val))) ;; inverse of prin1 in mml-insert-tag (push (cons (intern elem) val) contents) (skip-chars-forward " \t\n")) (goto-char (match-end 0)) @@ -485,7 +490,12 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (setq charset nil coding nil)) (charset - (setq charset (intern (downcase charset))))) + ;; The value of `charset' might be a bogus alias that + ;; `mm-charset-synonym-alist' provides, like `utf8', + ;; so we prefer the MIME charset that Emacs knows for + ;; the coding system `coding'. + (setq charset (or (mm-coding-system-to-mime-charset coding) + (intern (downcase charset)))))) (if (and (not raw) (member (car (split-string type "/")) '("text" "message"))) (progn @@ -518,7 +528,10 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." ;; `m-g-d-t' will be bound to "message/rfc822" ;; when encoding an article to be forwarded. (mml-generate-default-type "text/plain")) - (mml-to-mime)) + (mml-to-mime) + ;; Update handle so mml-compute-boundary can + ;; detect collisions with the nested parts. + (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)))) @@ -583,7 +596,9 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (unless raw (setq charset (mm-encode-body charset)))) (insert contents))))) - (setq encoding (mm-encode-buffer type) + (if (setq encoding (cdr (assq 'encoding cont))) + (setq encoding (intern (downcase encoding)))) + (setq encoding (mm-encode-buffer type encoding) coded (mm-string-as-multibyte (buffer-string)))) (mml-insert-mime-headers cont type charset encoding nil) (insert "\n" coded)))) @@ -695,7 +710,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (defun mml-compute-boundary-1 (cont) (let (filename) (cond - ((eq (car cont) 'part) + ((member (car cont) '(part mml)) (with-temp-buffer (cond ((cdr (assq 'buffer cont)) @@ -894,12 +909,18 @@ If HANDLES is non-nil, use it instead reparsing the buffer." ;; Determine type and stuff. (unless (stringp (car handle)) (unless (setq textp (equal (mm-handle-media-supertype handle) "text")) - (save-excursion - (set-buffer (setq buffer (mml-generate-new-buffer " *mml*"))) - (mm-insert-part handle 'no-cache) - (if (setq mmlp (equal (mm-handle-media-type handle) - "message/rfc822")) - (mime-to-mml))))) + (with-current-buffer (setq buffer (mml-generate-new-buffer " *mml*")) + (if (eq (mail-content-type-get (mm-handle-type handle) 'charset) + 'gnus-decoded) + ;; A part that mm-uu dissected from a non-MIME message + ;; because of `gnus-article-emulate-mime'. + (progn + (mm-enable-multibyte) + (insert-buffer-substring (mm-handle-buffer handle))) + (mm-insert-part handle 'no-cache) + (if (setq mmlp (equal (mm-handle-media-type handle) + "message/rfc822")) + (mime-to-mml)))))) (if mmlp (mml-insert-mml-markup handle nil t t) (unless (and no-markup @@ -1017,14 +1038,6 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (define-key main "\C-c\C-m" map) main)) -(defun mml-toggle-gcc-externalize-attachments () - (interactive) - (prog1 - (setq gnus-gcc-externalize-attachments - (not gnus-gcc-externalize-attachments)) - (message "gnus-gcc-externalize-attachments is `%s'." - gnus-gcc-externalize-attachments))) - (easy-menu-define mml-menu mml-mode-map "" `("Attachments" @@ -1037,13 +1050,29 @@ If HANDLES is non-nil, use it instead reparsing the buffer." ["Attach External..." mml-attach-external ,@(if (featurep 'xemacs) '(t) '(:help "Attach reference to an external file"))] - ;; ["Externalize Attachments" - ;; (lambda () (interactive) (mml-toggle-gcc-externalize-attachments)) - ;; ,@(if (featurep 'xemacs) nil - ;; '(:help "Save attachments as external parts in Gcc copies")) - ;; :visible (booleanp gnus-gcc-externalize-attachments) - ;; :style radio - ;; :selected (equal gnus-gcc-externalize-attachments t) ] + ;; FIXME: Is it possible to do this without using + ;; `gnus-gcc-externalize-attachments'? + ["Externalize Attachments" + (lambda () + (interactive) + (if (not (and (boundp 'gnus-gcc-externalize-attachments) + (memq gnus-gcc-externalize-attachments + '(all t nil)))) + ;; Stupid workaround for XEmacs not honoring :visible. + (message "Can't handle this value of `gnus-gcc-externalize-attachments'") + (setq gnus-gcc-externalize-attachments + (not gnus-gcc-externalize-attachments)) + (message "gnus-gcc-externalize-attachments is `%s'." + gnus-gcc-externalize-attachments))) + ;; XEmacs barfs on :visible. + ,@(if (featurep 'xemacs) nil + '(:visible (and (boundp 'gnus-gcc-externalize-attachments) + (memq gnus-gcc-externalize-attachments + '(all t nil))))) + :style toggle + :selected gnus-gcc-externalize-attachments + ,@(if (featurep 'xemacs) nil + '(:help "Save attachments as external parts in Gcc copies"))] "----" ;; ("Change Security Method" @@ -1095,33 +1124,30 @@ If HANDLES is non-nil, use it instead reparsing the buffer." ,@(if (featurep 'xemacs) '(t) '(:help "Display the Emacs MIME manual"))] ["PGG manual" (lambda () (interactive) (message-info mml2015-use)) - :visible (equal mml2015-use 'pgg) + ;; XEmacs barfs on :visible. + ,@(if (featurep 'xemacs) nil + '(:visible (and (boundp 'mml2015-use) (equal mml2015-use 'pgg)))) ,@(if (featurep 'xemacs) '(t) '(:help "Display the PGG manual"))] - ["EasyPG manual" (lambda () (interactive) (message-info mml2015-use)) - :visible (equal mml2015-use 'epg) + ["EasyPG manual" (lambda () (interactive) (require 'mml2015) (message-info mml2015-use)) + ;; XEmacs barfs on :visible. + ,@(if (featurep 'xemacs) nil + '(:visible (and (boundp 'mml2015-use) (equal mml2015-use 'epg)))) ,@(if (featurep 'xemacs) '(t) '(:help "Display the EasyPG manual"))])) -(defvar mml-mode nil - "Minor mode for editing MML.") - -(defun mml-mode (&optional arg) +(define-minor-mode mml-mode "Minor mode for editing MML. MML is the MIME Meta Language, a minor mode for composing MIME articles. See Info node `(emacs-mime)Composing'. \\{mml-mode-map}" - (interactive "P") - (when (set (make-local-variable 'mml-mode) - (if (null arg) (not mml-mode) - (> (prefix-numeric-value arg) 0))) - (add-minor-mode 'mml-mode " MML" mml-mode-map) + :lighter " MML" :keymap mml-mode-map + (when mml-mode (easy-menu-add mml-menu mml-mode-map) (when (boundp 'dnd-protocol-alist) (set (make-local-variable 'dnd-protocol-alist) - (append mml-dnd-protocol-alist dnd-protocol-alist))) - (run-hooks 'mml-mode-hook))) + (append mml-dnd-protocol-alist dnd-protocol-alist))))) ;;; ;;; Helper functions for reading MIME stuff from the minibuffer and @@ -1150,7 +1176,11 @@ If not set, `default-directory' will be used." (error "Permission denied: %s" file)) file)) +(declare-function mailcap-parse-mimetypes "mailcap" (&optional path force)) +(declare-function mailcap-mime-types "mailcap" ()) + (defun mml-minibuffer-read-type (name &optional default) + (require 'mailcap) (mailcap-parse-mimetypes) (let* ((default (or default (mm-default-file-encoding name) @@ -1271,13 +1301,24 @@ 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))) - (save-excursion - (unless (message-in-body-p) (goto-char (point-max))) + ;; 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)))))) (mml-insert-empty-tag 'part 'type type - 'filename file + ;; icicles redefines read-file-name and returns a + ;; string w/ text properties :-/ + 'filename (mm-substring-no-properties file) 'disposition (or disposition "attachment") - 'description description))) + 'description description) + (when head + (unless (prog1 + (pos-visible-in-window-p) + (goto-char head)) + (message "The file \"%s\" has been attached at the end of the message" + (file-name-nondirectory file)))))) (defun mml-dnd-attach-file (uri action) "Attach a drag and drop file. @@ -1303,19 +1344,31 @@ Ask for type, description or disposition according to (setq disposition (mml-minibuffer-read-disposition type nil file))) (mml-attach-file file type description disposition))))) -(defun mml-attach-buffer (buffer &optional type description) +(defun mml-attach-buffer (buffer &optional type description disposition) "Attach a buffer to the outgoing MIME message. -See `mml-attach-file' for details of operation." +BUFFER is the name of the buffer to attach. See +`mml-attach-file' for details of operation." (interactive (let* ((buffer (read-buffer "Attach buffer: ")) (type (mml-minibuffer-read-type buffer "text/plain")) - (description (mml-minibuffer-read-description))) - (list buffer type description))) - (save-excursion - (unless (message-in-body-p) (goto-char (point-max))) + (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)))))) (mml-insert-empty-tag 'part 'type type 'buffer buffer - 'disposition "attachment" - 'description description))) + 'disposition disposition + 'description description) + (when head + (unless (prog1 + (pos-visible-in-window-p) + (goto-char head)) + (message + "The buffer \"%s\" has been attached at the end of the message" + buffer))))) (defun mml-attach-external (file &optional type description) "Attach an external file into the buffer. @@ -1326,26 +1379,38 @@ TYPE is the MIME type to use." (type (mml-minibuffer-read-type file)) (description (mml-minibuffer-read-description))) (list file type description))) - (save-excursion - (unless (message-in-body-p) (goto-char (point-max))) + ;; 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)))))) (mml-insert-empty-tag 'external 'type type 'name file - 'disposition "attachment" 'description description))) + 'disposition "attachment" 'description description) + (when head + (unless (prog1 + (pos-visible-in-window-p) + (goto-char head)) + (message "The file \"%s\" has been attached at the end of the message" + (file-name-nondirectory file)))))) (defun mml-insert-multipart (&optional type) - (interactive (list (completing-read "Multipart type (default mixed): " - '(("mixed") ("alternative") ("digest") ("parallel") - ("signed") ("encrypted")) - nil nil "mixed"))) + (interactive (if (message-in-body-p) + (list (completing-read "Multipart type (default mixed): " + '(("mixed") ("alternative") + ("digest") ("parallel") + ("signed") ("encrypted")) + nil nil "mixed")) + (error "Use this command in the message body"))) (or type (setq type "mixed")) (mml-insert-empty-tag "multipart" 'type type) (forward-line -1)) (defun mml-insert-part (&optional type) - (interactive - (list (mml-minibuffer-read-type ""))) - (mml-insert-tag 'part 'type type 'disposition "inline") - (forward-line -1)) + (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")) (declare-function message-subscribed-p "message" ()) (declare-function message-make-mail-followup-to "message" @@ -1387,6 +1452,7 @@ or the `pop-to-buffer' function." (setq mml-preview-buffer (generate-new-buffer (concat (if raw "*Raw MIME preview of " "*MIME preview of ") (buffer-name)))) + (require 'gnus-msg) ; for gnus-setup-posting-charset (save-excursion (let* ((buf (current-buffer)) (message-options message-options) @@ -1504,5 +1570,4 @@ or the `pop-to-buffer' function." (provide 'mml) -;;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12 ;;; mml.el ends here