X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmml.el;h=3cf0f3701fd68b0774cd44a99f19884edb30cda2;hp=157b748e0b1b33fe756abb3b2c6ff50bdf783eed;hb=92bc187d1fcbe58bbd9c638b69a614c3bbad208e;hpb=63c4e2967abeb93a747278d0daa6dc9e03be4882 diff --git a/lisp/mml.el b/lisp/mml.el index 157b748e0..3cf0f3701 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -1,49 +1,57 @@ ;;; mml.el --- A package for parsing and validating MML documents -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006 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 2, 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. +(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-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")) - (eval-when-compile - (autoload 'dnd-get-local-file-name "dnd")) + (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") +(autoload 'message-in-body-p "message") +(autoload 'message-mail-p "message") (defvar gnus-article-mime-handles) (defvar gnus-mouse-2) @@ -54,6 +62,8 @@ (defvar message-posting-charset) (defvar message-required-mail-headers) (defvar message-required-news-headers) +(defvar dnd-protocol-alist) +(defvar mml-dnd-protocol-alist) (defcustom mml-content-type-parameters '(name access-type expiration size permission format) @@ -71,10 +81,50 @@ These parameters are generated in Content-Disposition header if exists." :type '(repeat (symbol :tag "Parameter")) :group 'message) -(defcustom mml-insert-mime-headers-always nil +(defcustom mml-content-disposition-alist + '((text (rtf . "attachment") (t . "inline")) + (t . "attachment")) + "Alist of MIME types or regexps matching file names and default dispositions. +Each element should be one of the following three forms: + + (REGEXP . DISPOSITION) + (SUPERTYPE (SUBTYPE . DISPOSITION) (SUBTYPE . DISPOSITION)...) + (TYPE . DISPOSITION) + +Where REGEXP is a string which matches the file name (if any) of an +attachment, SUPERTYPE, SUBTYPE and TYPE should be symbols which are a +MIME supertype (e.g., text), a MIME subtype (e.g., plain) and a MIME +type (e.g., text/plain) respectively, and DISPOSITION should be either +the string \"attachment\" or the string \"inline\". The value t for +SUPERTYPE, SUBTYPE or TYPE matches any of those types. The first +match found will be used." + :version "23.1" ;; No Gnus + :type (let ((dispositions '(radio :format "DISPOSITION: %v" + :value "attachment" + (const :format "%v " "attachment") + (const :format "%v\n" "inline")))) + `(repeat + :offset 0 + (choice :format "%[Value Menu%]%v" + (cons :tag "(REGEXP . DISPOSITION)" :extra-offset 4 + (regexp :tag "REGEXP" :value ".*") + ,dispositions) + (cons :tag "(SUPERTYPE (SUBTYPE . DISPOSITION)...)" + :indent 0 + (symbol :tag " SUPERTYPE" :value text) + (repeat :format "%v%i\n" :offset 0 :extra-offset 4 + (cons :format "%v" :extra-offset 5 + (symbol :tag "SUBTYPE" :value t) + ,dispositions))) + (cons :tag "(TYPE . DISPOSITION)" :extra-offset 4 + (symbol :tag "TYPE" :value t) + ,dispositions)))) + :group 'message) + +(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) @@ -179,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))) @@ -205,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") @@ -346,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)) @@ -406,7 +461,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (mml-multipart-number mml-multipart-number)) (if (not cont) nil - (with-temp-buffer + (mm-with-multibyte-buffer (if (and (consp (car cont)) (= (length cont) 1)) (mml-generate-mime-1 (car cont)) @@ -436,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 @@ -469,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)))) @@ -496,7 +559,13 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." ;; insert a "; format=flowed" string unless the ;; user has already specified it. (setq flowed (null (assq 'format cont))))) - (setq charset (mm-encode-body charset)) + ;; Prefer `utf-8' for text/calendar parts. + (if (or charset + (not (string= type "text/calendar"))) + (setq charset (mm-encode-body charset)) + (let ((mm-coding-system-priorities + (cons 'utf-8 mm-coding-system-priorities))) + (setq charset (mm-encode-body)))) (setq encoding (mm-body-encoding charset (cdr (assq 'encoding cont)))))) (setq coded (buffer-string))) @@ -506,9 +575,9 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (mm-with-unibyte-buffer (cond ((cdr (assq 'buffer cont)) - (insert (with-current-buffer (cdr (assq 'buffer cont)) - (mm-with-unibyte-current-buffer - (buffer-string))))) + (insert (mm-string-as-unibyte + (with-current-buffer (cdr (assq 'buffer cont)) + (buffer-string))))) ((and filename (not (equal (cdr (assq 'nofile cont)) "yes"))) (let ((coding-system-for-read mm-binary-coding-system)) @@ -525,14 +594,15 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (progn (mm-enable-multibyte) (insert contents) - (setq charset (mm-encode-body charset))) + (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") - (mm-with-unibyte-current-buffer - (insert coded))))) + (insert "\n" coded)))) ((eq (car cont) 'external) (insert "Content-Type: message/external-body") (let ((parameters (mml-parameter-string @@ -641,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)) @@ -668,6 +738,30 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." "") mml-base-boundary)) +(defun mml-content-disposition (type &optional filename) + "Return a default disposition name suitable to TYPE or FILENAME." + (let ((defs mml-content-disposition-alist) + disposition def types) + (while (and (not disposition) defs) + (setq def (pop defs)) + (cond ((stringp (car def)) + (when (and filename + (string-match (car def) filename)) + (setq disposition (cdr def)))) + ((consp (cdr def)) + (when (string= (car (setq types (split-string type "/"))) + (car def)) + (setq type (cadr types) + types (cdr def)) + (while (and (not disposition) types) + (setq def (pop types)) + (when (or (eq (car def) t) (string= type (car def))) + (setq disposition (cdr def)))))) + (t + (when (or (eq (car def) t) (string= type (car def))) + (setq disposition (cdr def)))))) + (or disposition "attachment"))) + (defun mml-insert-mime-headers (cont type charset encoding flowed) (let (parameters id disposition description) (setq parameters @@ -698,7 +792,9 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." cont mml-content-disposition-parameters)) (when (or (setq disposition (cdr (assq 'disposition cont))) parameters) - (insert "Content-Disposition: " (or disposition "inline")) + (insert "Content-Disposition: " + (or disposition + (mml-content-disposition type (cdr (assq 'filename cont))))) (when parameters (mml-insert-parameter-string cont mml-content-disposition-parameters)) @@ -737,9 +833,9 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (mail-header-encode-parameter (symbol-name type) value)))))) -(eval-when-compile - (defvar ange-ftp-name-format) - (defvar efs-path-regexp)) +(defvar ange-ftp-name-format) +(defvar efs-path-regexp) + (defun mml-parse-file-name (path) (if (if (boundp 'efs-path-regexp) (string-match efs-path-regexp path) @@ -761,6 +857,10 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." ;;; Transforming MIME to MML ;;; +;; message-narrow-to-head autoloads message. +(declare-function message-remove-header "message" + (header &optional is-regexp first reverse)) + (defun mime-to-mml (&optional handles) "Translate the current buffer (which should be a message) into MML. If HANDLES is non-nil, use it instead reparsing the buffer." @@ -786,28 +886,42 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (message-remove-header "Content-Disposition") (message-remove-header "Content-Transfer-Encoding"))) +(autoload 'message-encode-message-body "message") +(declare-function message-narrow-to-headers-or-head "message" ()) + (defun mml-to-mime () "Translate the current buffer from MML to MIME." - (message-encode-message-body) + ;; `message-encode-message-body' will insert an encoded Content-Description + ;; header in the message header if the body contains a single part + ;; that is specified by a user with a MML tag containing a description + ;; token. So, we encode the message header first to prevent the encoded + ;; Content-Description header from being encoded again. (save-restriction (message-narrow-to-headers-or-head) ;; Skip past any From_ headers. (while (looking-at "From ") (forward-line 1)) (let ((mail-parse-charset message-default-charset)) - (mail-encode-encoded-word-buffer)))) + (mail-encode-encoded-word-buffer))) + (message-encode-message-body)) (defun mml-insert-mime (handle &optional no-markup) (let (textp buffer mmlp) ;; 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 @@ -819,7 +933,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (goto-char (point-max)) (insert "<#/mml>\n")) ((stringp (car handle)) - (mapcar 'mml-insert-mime (cdr handle)) + (mapc 'mml-insert-mime (cdr handle)) (insert "<#/multipart>\n")) (textp (let ((charset (mail-content-type-get @@ -933,10 +1047,34 @@ If HANDLES is non-nil, use it instead reparsing the buffer." '(:help "Attach a file at point"))] ["Attach Buffer..." mml-attach-buffer ,@(if (featurep 'xemacs) '(t) - '(:help "Attach a buffer to the outgoing MIME message"))] + '(:help "Attach a buffer to the outgoing message"))] ["Attach External..." mml-attach-external ,@(if (featurep 'xemacs) '(t) - '(:help "Attach reference to file"))] + '(:help "Attach reference to an external file"))] + ;; 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" ["PGP/MIME" @@ -964,6 +1102,10 @@ If HANDLES is non-nil, use it instead reparsing the buffer." ["Encrypt/Sign off" mml-unsecure-message ,@(if (featurep 'xemacs) '(t) '(:help "Don't Encrypt/Sign Message"))] + ;; Do we have separate encrypt and encrypt/sign commands for parts? + ["Sign Part" mml-secure-sign t] + ["Encrypt Part" mml-secure-encrypt t] + "----" ;; Maybe we could remove these, because people who write MML most probably ;; don't use the menu: ["Insert Part..." mml-insert-part @@ -971,9 +1113,6 @@ If HANDLES is non-nil, use it instead reparsing the buffer." ["Insert Multipart..." mml-insert-multipart :active (message-in-body-p)] ;; - ;; Do we have separate encrypt and encrypt/sign commands for parts? - ["Sign Part" mml-secure-sign t] - ["Encrypt Part" mml-secure-encrypt t] ;;["Narrow" mml-narrow-to-part t] ["Quote MML in region" mml-quote-region :active (message-mark-active-p) @@ -985,39 +1124,49 @@ If HANDLES is non-nil, use it instead reparsing the buffer." ["Emacs MIME manual" (lambda () (interactive) (message-info 4)) ,@(if (featurep 'xemacs) '(t) '(:help "Display the Emacs MIME manual"))] - ["PGG manual" (lambda () (interactive) (message-info 16)) + ["PGG manual" (lambda () (interactive) (message-info mml2015-use)) + ;; 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"))])) - -(defvar mml-mode nil - "Minor mode for editing MML.") + '(:help "Display the PGG manual"))] + ["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"))])) -(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 - (symbol-value '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 ;;; inserting stuff to the buffer. ;;; +(defcustom mml-default-directory mm-default-directory + "The default directory where mml will find files. +If not set, `default-directory' will be used." + :type '(choice directory (const :tag "Default" nil)) + :version "23.1" ;; No Gnus + :group 'message) + (defun mml-minibuffer-read-file (prompt) (let* ((completion-ignored-extensions nil) - (file (read-file-name prompt nil nil t))) + (file (read-file-name prompt + (or mml-default-directory default-directory) + nil t))) ;; Prevent some common errors. This is inspired by similar code in ;; VM. (when (file-directory-p file) @@ -1028,7 +1177,11 @@ See Info node `(emacs-mime)Composing'. (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) @@ -1036,9 +1189,10 @@ See Info node `(emacs-mime)Composing'. ;; 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))) @@ -1049,16 +1203,13 @@ See Info node `(emacs-mime)Composing'. (setq description nil)) description)) -(defun mml-minibuffer-read-disposition (type &optional default) - (unless default (setq default - (if (and (string-match "\\`text/" type) - (not (string-match "\\`text/rtf\\'" type))) - "inline" - "attachment"))) - (let ((disposition (completing-read - (format "Disposition (default %s): " default) - '(("attachment") ("inline") ("")) - nil t nil nil default))) +(defun mml-minibuffer-read-disposition (type &optional default filename) + (unless default + (setq default (mml-content-disposition type filename))) + (let ((disposition (gnus-completing-read + "Disposition" + '("attachment" "inline") + t nil nil default))) (if (not (equal disposition "")) disposition default))) @@ -1114,7 +1265,7 @@ See `dnd-protocol-alist' for more information. When nil, behave as in other buffers." :type '(choice (repeat (cons (regexp) (function))) (const :tag "Behave as in other buffers" nil)) - :version "23.0" ;; No Gnus + :version "22.1" ;; Gnus 5.10.9 :group 'message) (defcustom mml-dnd-attach-options nil @@ -1125,14 +1276,14 @@ If it is a list, valid members are `type', `description' and don't ask for options. If it is t, ask the user whether or not to specify options." :type '(choice - (const :tag "Non" nil) + (const :tag "None" nil) (const :tag "Query" t) (list :value (type description disposition) (set :inline t (const type) (const description) (const disposition)))) - :version "23.0" ;; No Gnus + :version "22.1" ;; Gnus 5.10.9 :group 'message) (defun mml-attach-file (file &optional type description disposition) @@ -1150,15 +1301,26 @@ body) or \"attachment\" (separate from the body)." (let* ((file (mml-minibuffer-read-file "Attach file: ")) (type (mml-minibuffer-read-type file)) (description (mml-minibuffer-read-description)) - (disposition (mml-minibuffer-read-disposition type))) + (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. @@ -1181,22 +1343,34 @@ Ask for type, description or disposition according to (when (memq 'description mml-dnd-attach-options) (setq description (mml-minibuffer-read-description))) (when (memq 'disposition mml-dnd-attach-options) - (setq disposition (mml-minibuffer-read-disposition type))) + (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. @@ -1207,26 +1381,43 @@ 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" + (&optional only-show-subscribed)) +(declare-function message-position-on-field "message" (header &rest afters)) (defun mml-preview-insert-mail-followup-to () "Insert a Mail-Followup-To header before previewing an article. @@ -1240,6 +1431,17 @@ Should be adopted if code in `message-send-mail' is changed." (defvar mml-preview-buffer nil) +(autoload 'gnus-make-hashtable "gnus-util") +(autoload 'widget-button-press "wid-edit" nil t) +(declare-function widget-event-point "wid-edit" (event)) +;; If gnus-buffer-configuration is bound this is loaded. +(declare-function gnus-configure-windows "gnus-win" (setting &optional force)) +;; Called after message-mail-p, which autoloads message. +(declare-function message-news-p "message" ()) +(declare-function message-options-set-recipient "message" ()) +(declare-function message-generate-headers "message" (headers)) +(declare-function message-sort-headers "message" ()) + (defun mml-preview (&optional raw) "Display current buffer with Gnus, in a new buffer. If RAW, display a raw encoded MIME message. @@ -1252,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) @@ -1369,5 +1572,4 @@ or the `pop-to-buffer' function." (provide 'mml) -;;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12 ;;; mml.el ends here