X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmml.el;h=43e86cb6c34b1d2686071b523d3f6e09e0c8825c;hb=b0eccd76f35ef80c3ad13f09e588d49358e9c22a;hp=0e65553d0adc9d86be0759b2e4a7deab3fe0f0f5;hpb=db9b31721196ea16708a1c448f4632f620a56724;p=gnus diff --git a/lisp/mml.el b/lisp/mml.el index 0e65553d0..43e86cb6c 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -1,31 +1,29 @@ ;;; 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: ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -35,17 +33,20 @@ (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 'gnus-completing-read "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 +121,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 +229,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 +258,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 +401,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 +491,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 +529,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 +597,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 +711,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 +910,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 @@ -1105,35 +1127,28 @@ If HANDLES is non-nil, use it instead reparsing the buffer." ["PGG manual" (lambda () (interactive) (message-info mml2015-use)) ;; XEmacs barfs on :visible. ,@(if (featurep 'xemacs) nil - '(:visible (equal mml2015-use 'pgg))) + '(: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)) + ["EasyPG manual" (lambda () (interactive) (require 'mml2015) (message-info mml2015-use)) ;; XEmacs barfs on :visible. ,@(if (featurep 'xemacs) nil - '(:visible (equal mml2015-use 'epg))) + '(: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 @@ -1162,7 +1177,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) @@ -1170,9 +1189,10 @@ If not set, `default-directory' will be used." ;; looks like, and offer text/plain if it looks ;; like text/plain. "application/octet-stream")) - (string (completing-read - (format "Content type (default %s): " default) - (mapcar 'list (mailcap-mime-types))))) + (string (gnus-completing-read + "Content type" + (mailcap-mime-types) + nil nil nil default))) (if (not (equal string "")) string default))) @@ -1186,10 +1206,10 @@ If not set, `default-directory' will be used." (defun mml-minibuffer-read-disposition (type &optional default filename) (unless default (setq default (mml-content-disposition type filename))) - (let ((disposition (completing-read - (format "Disposition (default %s): " default) - '(("attachment") ("inline") ("")) - nil t nil nil default))) + (let ((disposition (gnus-completing-read + "Disposition" + '("attachment" "inline") + t nil nil default))) (if (not (equal disposition "")) disposition default))) @@ -1283,13 +1303,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. @@ -1325,11 +1356,21 @@ 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))) - (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 'buffer buffer 'disposition disposition - 'description description))) + '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. @@ -1340,26 +1381,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 (gnus-completing-read "Multipart type" + '("mixed" "alternative" + "digest" "parallel" + "signed" "encrypted") + 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" @@ -1401,6 +1454,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) @@ -1518,5 +1572,4 @@ or the `pop-to-buffer' function." (provide 'mml) -;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12 ;;; mml.el ends here