X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmml.el;h=e682b1b069b90cb35158b3aa372a1cdc885bc3b8;hp=fded4465d24d160e984a7135dbf2c65b9d7a7cf7;hb=e2c9efb05a1ae9e65fd40bab80466da331f3981b;hpb=5c80f368a0604f73a86cc4fe5e2e0c37ae76ef16 diff --git a/lisp/mml.el b/lisp/mml.el index fded4465d..e682b1b06 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -1,29 +1,32 @@ ;;; mml.el --- A package for parsing and validating MML documents -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 -;; Free Software Foundation, Inc. + +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;; 2007, 2008, 2009 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, 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) @@ -31,19 +34,38 @@ (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-add-minor-mode "gnus-ems") - (autoload 'gnus-make-local-hook "gnus-util") - (autoload 'message-fetch-field "message") - (autoload 'fill-flowed-encode "flow-fill") - (autoload 'message-posting-charset "message")) +(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") + +(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) +(defvar gnus-newsrc-hashtb) +(defvar message-default-charset) +(defvar message-deletable-headers) +(defvar message-options) +(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) "*A list of acceptable parameters in MML tag. These parameters are generated in Content-Type header if exists." + :version "22.1" :type '(repeat (symbol :tag "Parameter")) :group 'message) @@ -51,12 +73,54 @@ These parameters are generated in Content-Type header if exists." '(filename creation-date modification-date read-date) "*A list of acceptable parameters in MML tag. These parameters are generated in Content-Disposition header if exists." + :version "22.1" :type '(repeat (symbol :tag "Parameter")) :group 'message) +(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 nil "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" :type 'boolean :group 'message) @@ -120,7 +184,13 @@ unknown encoding; `use-ascii': always use ASCII for those characters with unknown encoding; `multipart': always send messages with more than one charsets.") -(defvar mml-generate-default-type "text/plain") +(defvar mml-generate-default-type "text/plain" + "Content type by which the Content-Type header can be omitted. +The Content-Type header will not be put in the MIME part if the type +equals the value and there's no parameter (e.g. charset, format, etc.) +and `mml-insert-mime-headers-always' is nil. The value will be bound +to \"message/rfc822\" when encoding an article to be forwarded as a MIME +part. This is for the internal use, you should never modify the value.") (defvar mml-buffer-list nil) @@ -131,19 +201,15 @@ one charsets.") (defun mml-destroy-buffers () (let (kill-buffer-hook) - (mapcar 'kill-buffer mml-buffer-list) + (mapc 'kill-buffer mml-buffer-list) (setq mml-buffer-list nil))) (defun mml-parse () "Parse the current buffer as an MML document." (save-excursion (goto-char (point-min)) - (let ((table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table mml-syntax-table) - (mml-parse-1)) - (set-syntax-table table))))) + (with-syntax-table mml-syntax-table + (mml-parse-1)))) (defun mml-parse-1 () "Parse the current buffer as an MML document." @@ -158,6 +224,8 @@ one charsets.") ;; included in the message (let* (secure-mode (taginfo (mml-read-tag)) + (keyfile (cdr (assq 'keyfile taginfo))) + (certfile (cdr (assq 'certfile taginfo))) (recipients (cdr (assq 'recipients taginfo))) (sender (cdr (assq 'sender taginfo))) (location (cdr (assq 'tag-location taginfo))) @@ -165,9 +233,8 @@ one charsets.") (method (cdr (assq 'method taginfo))) tags) (save-excursion - (if - (re-search-forward - "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t) + (if (re-search-forward + "<#/?\\(multipart\\|part\\|external\\|mml\\)." nil t) (setq secure-mode "multipart") (setq secure-mode "part"))) (save-excursion @@ -182,6 +249,10 @@ one charsets.") (setq tags (list "sign" method "encrypt" method)))) (eval `(mml-insert-tag ,secure-mode ,@tags + ,(if keyfile "keyfile") + ,keyfile + ,(if certfile "certfile") + ,certfile ,(if recipients "recipients") ,recipients ,(if sender "sender") @@ -381,7 +452,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)) @@ -397,23 +468,36 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (mml-tweak-part cont) (cond ((or (eq (car cont) 'part) (eq (car cont) 'mml)) - (let ((raw (cdr (assq 'raw cont))) - coded encoding charset filename type flowed) - (setq type (or (cdr (assq 'type cont)) "text/plain")) + (let* ((raw (cdr (assq 'raw cont))) + (filename (cdr (assq 'filename cont))) + (type (or (cdr (assq 'type cont)) + (if filename + (or (mm-default-file-encoding filename) + "application/octet-stream") + "text/plain"))) + (charset (cdr (assq 'charset cont))) + (coding (mm-charset-to-coding-system charset)) + encoding flowed coded) + (cond ((eq coding 'ascii) + (setq charset nil + coding nil)) + (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 (with-temp-buffer - (setq charset (mm-charset-to-coding-system - (cdr (assq 'charset cont)))) - (when (eq charset 'ascii) - (setq charset nil)) (cond ((cdr (assq 'buffer cont)) (insert-buffer-substring (cdr (assq 'buffer cont)))) - ((and (setq filename (cdr (assq 'filename cont))) + ((and filename (not (equal (cdr (assq 'nofile cont)) "yes"))) - (let ((coding-system-for-read charset)) + (let ((coding-system-for-read coding)) (mm-insert-file-contents filename))) ((eq 'mml (car cont)) (insert (cdr (assq 'contents cont)))) @@ -431,6 +515,10 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (cond ((eq (car cont) 'mml) (let ((mml-boundary (mml-compute-boundary cont)) + ;; It is necessary for the case where this + ;; function is called recursively since + ;; `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)) (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b"))) @@ -447,6 +535,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." ;; actually are hard newlines in the text. (let (use-hard-newlines) (when (and (string= type "text/plain") + (not (string= (cdr (assq 'sign cont)) "pgp")) (or (null (assq 'format cont)) (string= (cdr (assq 'format cont)) "flowed")) @@ -458,7 +547,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))) @@ -468,19 +563,32 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (mm-with-unibyte-buffer (cond ((cdr (assq 'buffer cont)) - (insert-buffer-substring (cdr (assq 'buffer cont)))) - ((and (setq filename (cdr (assq 'filename cont))) + (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)) - (mm-insert-file-contents filename nil nil nil nil t))) + (mm-insert-file-contents filename nil nil nil nil t)) + (unless charset + (setq charset (mm-coding-system-to-mime-charset + (mm-find-buffer-file-coding-system + filename))))) (t - (insert (cdr (assq 'contents cont))))) + (let ((contents (cdr (assq 'contents cont)))) + (if (if (featurep 'xemacs) + (string-match "[^\000-\377]" contents) + (mm-multibyte-string-p contents)) + (progn + (mm-enable-multibyte) + (insert contents) + (unless raw + (setq charset (mm-encode-body charset)))) + (insert contents))))) (setq encoding (mm-encode-buffer type) 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 @@ -510,15 +618,21 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." "access-type=url")) (when parameters (mml-insert-parameter-string - cont '(expiration size permission)))) - (insert "\n\n") - (insert "Content-Type: " (cdr (assq 'type cont)) "\n") - (insert "Content-ID: " (message-make-message-id) "\n") - (insert "Content-Transfer-Encoding: " - (or (cdr (assq 'encoding cont)) "binary")) - (insert "\n\n") - (insert (or (cdr (assq 'contents cont)))) - (insert "\n")) + cont '(expiration size permission))) + (insert "\n\n") + (insert "Content-Type: " + (or (cdr (assq 'type cont)) + (if name + (or (mm-default-file-encoding name) + "application/octet-stream") + "text/plain")) + "\n") + (insert "Content-ID: " (message-make-message-id) "\n") + (insert "Content-Transfer-Encoding: " + (or (cdr (assq 'encoding cont)) "binary")) + (insert "\n\n") + (insert (or (cdr (assq 'contents cont)))) + (insert "\n"))) ((eq (car cont) 'multipart) (let* ((type (or (cdr (assq 'type cont)) "mixed")) (mml-generate-default-type (if (equal type "digest") @@ -539,7 +653,8 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." ;; Skip `multipart' and attributes. (when (and (consp part) (consp (cdr part))) (insert "\n--" mml-boundary "\n") - (mml-generate-mime-1 part)))) + (mml-generate-mime-1 part) + (goto-char (point-max))))) (insert "\n--" mml-boundary "--\n"))))) (t (error "Invalid element: %S" cont))) @@ -554,7 +669,8 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (message-options-set 'message-sender sender)) (if (setq recipients (cdr (assq 'recipients cont))) (message-options-set 'message-recipients recipients)) - (let ((style (mml-signencrypt-style (first (or sign-item encrypt-item))))) + (let ((style (mml-signencrypt-style + (first (or sign-item encrypt-item))))) ;; check if: we're both signing & encrypting, both methods ;; are the same (why would they be different?!), and that ;; the signencrypt style allows for combined operation. @@ -588,7 +704,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (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)) + (mm-insert-file-contents filename nil nil nil nil t)) (t (insert (cdr (assq 'contents cont))))) (goto-char (point-min)) @@ -598,7 +714,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (incf mml-multipart-number))) (throw 'not-unique nil)))) ((eq (car cont) 'multipart) - (mapcar 'mml-compute-boundary-1 (cddr cont)))) + (mapc 'mml-compute-boundary-1 (cddr cont)))) t)) (defun mml-make-boundary (number) @@ -608,6 +724,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 @@ -623,10 +763,10 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." "Can't encode a part with several charsets")) (insert "Content-Type: " type) (when charset - (insert "; " (mail-header-encode-parameter - "charset" (symbol-name charset)))) + (mml-insert-parameter + (mail-header-encode-parameter "charset" (symbol-name charset)))) (when flowed - (insert "; format=flowed")) + (mml-insert-parameter "format=flowed")) (when parameters (mml-insert-parameter-string cont mml-content-type-parameters)) @@ -638,7 +778,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)) @@ -646,8 +788,11 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (unless (eq encoding '7bit) (insert (format "Content-Transfer-Encoding: %s\n" encoding))) (when (setq description (cdr (assq 'description cont))) - (insert "Content-Description: " - (mail-encode-encoded-word-string description) "\n")))) + (insert "Content-Description: ") + (setq description (prog1 + (point) + (insert description "\n"))) + (mail-encode-encoded-word-region description (point))))) (defun mml-parameter-string (cont types) (let ((string "") @@ -674,9 +819,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) @@ -698,13 +843,18 @@ 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." ;; First decode the head. (save-restriction (message-narrow-to-head) - (mail-decode-encoded-word-region (point-min) (point-max))) + (let ((rfc2047-quote-decoded-words-containing-tspecials t)) + (mail-decode-encoded-word-region (point-min) (point-max)))) (unless handles (setq handles (mm-dissect-buffer t))) (goto-char (point-min)) @@ -722,16 +872,24 @@ 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) @@ -740,7 +898,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (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) + (mm-insert-part handle 'no-cache) (if (setq mmlp (equal (mm-handle-media-type handle) "message/rfc822")) (mime-to-mml))))) @@ -755,7 +913,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 @@ -799,14 +957,20 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (defun mml-insert-parameter (&rest parameters) "Insert PARAMETERS in a nice way." - (dolist (param parameters) - (insert ";") - (let ((point (point))) + (let (start end) + (dolist (param parameters) + (insert ";") + (setq start (point)) (insert " " param) - (when (> (current-column) 71) - (goto-char point) - (insert "\n ") - (end-of-line))))) + (setq end (point)) + (goto-char start) + (end-of-line) + (if (> (current-column) 76) + (progn + (goto-char start) + (insert "\n") + (goto-char (1+ end))) + (goto-char end))))) ;;; ;;; Mode for inserting and editing MML forms @@ -819,6 +983,11 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (encryptpart (make-sparse-keymap)) (map (make-sparse-keymap)) (main (make-sparse-keymap))) + (define-key map "\C-s" 'mml-secure-message-sign) + (define-key map "\C-c" 'mml-secure-message-encrypt) + (define-key map "\C-e" 'mml-secure-message-sign-encrypt) + (define-key map "\C-p\C-s" 'mml-secure-sign) + (define-key map "\C-p\C-c" 'mml-secure-encrypt) (define-key sign "p" 'mml-secure-message-sign-pgpmime) (define-key sign "o" 'mml-secure-message-sign-pgp) (define-key sign "s" 'mml-secure-message-sign-smime) @@ -856,28 +1025,97 @@ If HANDLES is non-nil, use it instead reparsing the buffer." ["Attach File..." mml-attach-file ,@(if (featurep 'xemacs) '(t) '(:help "Attach a file at point"))] - ["Attach Buffer..." mml-attach-buffer t] - ["Attach External..." mml-attach-external t] - ["Insert Part..." mml-insert-part t] - ["Insert Multipart..." mml-insert-multipart t] - ["PGP/MIME Sign" mml-secure-message-sign-pgpmime t] - ["PGP/MIME Encrypt" mml-secure-message-encrypt-pgpmime t] - ["PGP Sign" mml-secure-message-sign-pgp t] - ["PGP Encrypt" mml-secure-message-encrypt-pgp t] - ["S/MIME Sign" mml-secure-message-sign-smime t] - ["S/MIME Encrypt" mml-secure-message-encrypt-smime t] - ("Secure MIME part" - ["PGP/MIME Sign Part" mml-secure-sign-pgpmime t] - ["PGP/MIME Encrypt Part" mml-secure-encrypt-pgpmime t] - ["PGP Sign Part" mml-secure-sign-pgp t] - ["PGP Encrypt Part" mml-secure-encrypt-pgp t] - ["S/MIME Sign Part" mml-secure-sign-smime t] - ["S/MIME Encrypt Part" mml-secure-encrypt-smime t]) - ["Encrypt/Sign off" mml-unsecure-message t] + ["Attach Buffer..." mml-attach-buffer + ,@(if (featurep 'xemacs) '(t) + '(:help "Attach a buffer to the outgoing message"))] + ["Attach External..." mml-attach-external + ,@(if (featurep 'xemacs) '(t) + '(: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" + (lambda () (interactive) (setq mml-secure-method "pgpmime")) + ,@(if (featurep 'xemacs) nil + '(:help "Set Security Method to PGP/MIME")) + :style radio + :selected (equal mml-secure-method "pgpmime") ] + ["S/MIME" + (lambda () (interactive) (setq mml-secure-method "smime")) + ,@(if (featurep 'xemacs) nil + '(:help "Set Security Method to S/MIME")) + :style radio + :selected (equal mml-secure-method "smime") ] + ["Inline PGP" + (lambda () (interactive) (setq mml-secure-method "pgp")) + ,@(if (featurep 'xemacs) nil + '(:help "Set Security Method to inline PGP")) + :style radio + :selected (equal mml-secure-method "pgp") ] ) + ;; + ["Sign Message" mml-secure-message-sign t] + ["Encrypt Message" mml-secure-message-encrypt t] + ["Sign and Encrypt Message" mml-secure-message-sign-encrypt t] + ["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 + :active (message-in-body-p)] + ["Insert Multipart..." mml-insert-multipart + :active (message-in-body-p)] + ;; ;;["Narrow" mml-narrow-to-part t] - ["Quote MML" mml-quote-region t] + ["Quote MML in region" mml-quote-region + :active (message-mark-active-p) + ,@(if (featurep 'xemacs) nil + '(:help "Quote MML tags in region"))] ["Validate MML" mml-validate t] - ["Preview" mml-preview t])) + ["Preview" mml-preview t] + "----" + ["Emacs MIME manual" (lambda () (interactive) (message-info 4)) + ,@(if (featurep 'xemacs) '(t) + '(:help "Display the Emacs MIME manual"))] + ["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"))] + ["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.") @@ -892,8 +1130,11 @@ See Info node `(emacs-mime)Composing'. (when (set (make-local-variable 'mml-mode) (if (null arg) (not mml-mode) (> (prefix-numeric-value arg) 0))) - (gnus-add-minor-mode 'mml-mode " MML" mml-mode-map) + (add-minor-mode 'mml-mode " MML" mml-mode-map) (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))) ;;; @@ -901,9 +1142,18 @@ See Info node `(emacs-mime)Composing'. ;;; 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) @@ -935,15 +1185,13 @@ See Info node `(emacs-mime)Composing'. (setq description nil)) description)) -(defun mml-minibuffer-read-disposition (type &optional default) - (let* ((default (or default - (if (string-match "^text/.*" type) - "inline" - "attachment"))) - (disposition (completing-read "Disposition: " - '(("attachment") ("inline") ("")) - nil - nil))) +(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))) (if (not (equal disposition "")) disposition default))) @@ -990,36 +1238,102 @@ See Info node `(emacs-mime)Composing'. ;;; Attachment functions. +(defcustom mml-dnd-protocol-alist + '(("^file:///" . mml-dnd-attach-file) + ("^file://" . dnd-open-file) + ("^file:" . mml-dnd-attach-file)) + "The functions to call when a drop in `mml-mode' is made. +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 "22.1" ;; Gnus 5.10.9 + :group 'message) + +(defcustom mml-dnd-attach-options nil + "Which options should be queried when attaching a file via drag and drop. + +If it is a list, valid members are `type', `description' and +`disposition'. `disposition' implies `type'. If it is nil, +don't ask for options. If it is t, ask the user whether or not +to specify options." + :type '(choice + (const :tag "None" nil) + (const :tag "Query" t) + (list :value (type description disposition) + (set :inline t + (const type) + (const description) + (const disposition)))) + :version "22.1" ;; Gnus 5.10.9 + :group 'message) + (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]'. -FILE is the name of the file to attach. TYPE is its content-type, a -string of the form \"type/subtype\". DESCRIPTION is a one-line -description of the attachment." +FILE is the name of the file to attach. TYPE is its +content-type, a string of the form \"type/subtype\". DESCRIPTION +is a one-line description of the attachment. The DISPOSITION +specifies how the attachment is intended to be displayed. It can +be either \"inline\" (displayed automatically within the message +body) or \"attachment\" (separate from the body)." (interactive (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))) - (mml-insert-empty-tag 'part - 'type type - 'filename file - 'disposition (or disposition "attachment") - 'description description)) - -(defun mml-attach-buffer (buffer &optional type description) + (save-excursion + (unless (message-in-body-p) (goto-char (point-max))) + (mml-insert-empty-tag 'part + 'type type + ;; icicles redefines read-file-name and returns a + ;; string w/ text properties :-/ + 'filename (mm-substring-no-properties file) + 'disposition (or disposition "attachment") + 'description description))) + +(defun mml-dnd-attach-file (uri action) + "Attach a drag and drop file. + +Ask for type, description or disposition according to +`mml-dnd-attach-options'." + (let ((file (dnd-get-local-file-name uri t))) + (when (and file (file-regular-p file)) + (let ((mml-dnd-attach-options mml-dnd-attach-options) + type description disposition) + (setq mml-dnd-attach-options + (when (and (eq mml-dnd-attach-options t) + (not + (y-or-n-p + "Use default type, disposition and description? "))) + '(type description disposition))) + (when (or (memq 'type mml-dnd-attach-options) + (memq 'disposition mml-dnd-attach-options)) + (setq type (mml-minibuffer-read-type file))) + (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 nil file))) + (mml-attach-file file type description disposition))))) + +(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))) - (mml-insert-empty-tag 'part 'type type 'buffer buffer - 'disposition "attachment" 'description description)) + (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))) + (mml-insert-empty-tag 'part 'type type 'buffer buffer + 'disposition disposition + 'description description))) (defun mml-attach-external (file &optional type description) "Attach an external file into the buffer. @@ -1030,8 +1344,10 @@ TYPE is the MIME type to use." (type (mml-minibuffer-read-type file)) (description (mml-minibuffer-read-description))) (list file type description))) - (mml-insert-empty-tag 'external 'type type 'name file - 'disposition "attachment" 'description description)) + (save-excursion + (unless (message-in-body-p) (goto-char (point-max))) + (mml-insert-empty-tag 'external 'type type 'name file + 'disposition "attachment" 'description description))) (defun mml-insert-multipart (&optional type) (interactive (list (completing-read "Multipart type (default mixed): " @@ -1049,6 +1365,11 @@ TYPE is the MIME type to use." (mml-insert-tag 'part 'type type 'disposition "inline") (forward-line -1)) +(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. Should be adopted if code in `message-send-mail' is changed." @@ -1059,10 +1380,31 @@ Should be adopted if code in `message-send-mail' is changed." (message-position-on-field "Mail-Followup-To" "X-Draft-From") (insert (message-make-mail-followup-to)))) +(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, don't highlight the article." +If RAW, display a raw encoded MIME message. + +The window layout for the preview buffer is controled 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." (interactive "P") + (setq mml-preview-buffer (generate-new-buffer + (concat (if raw "*Raw MIME preview of " + "*MIME preview of ") (buffer-name)))) (save-excursion (let* ((buf (current-buffer)) (message-options message-options) @@ -1074,13 +1416,13 @@ If RAW, don't highlight the article." (message-fetch-field "Newsgroups"))) message-posting-charset))) (message-options-set-recipient) - (switch-to-buffer (generate-new-buffer - (concat (if raw "*Raw MIME preview of " - "*MIME preview of ") (buffer-name)))) (when (boundp 'gnus-buffers) - (push (current-buffer) gnus-buffers)) - (erase-buffer) - (insert-buffer-substring buf) + (push mml-preview-buffer gnus-buffers)) + (save-restriction + (widen) + (set-buffer mml-preview-buffer) + (erase-buffer) + (insert-buffer-substring buf)) (mml-preview-insert-mail-followup-to) (let ((message-deletable-headers (if (message-news-p) nil @@ -1093,6 +1435,7 @@ If RAW, don't highlight the article." (concat "^" (regexp-quote mail-header-separator) "\n") nil t) (replace-match "\n")) (let ((mail-header-separator ""));; mail-header-separator is removed. + (message-sort-headers) (mml-to-mime)) (if raw (when (fboundp 'set-buffer-multibyte) @@ -1125,7 +1468,15 @@ If RAW, don't highlight the article." (lambda (event) (interactive "@e") (widget-button-press (widget-event-point event) event))) - (goto-char (point-min))))) + ;; FIXME: Buffer is in article mode, but most tool bar commands won't + ;; work. Maybe only keep the following icons: search, print, quit + (goto-char (point-min)))) + (if (and (not (mm-special-display-p (buffer-name mml-preview-buffer))) + (boundp 'gnus-buffer-configuration) + (assq 'mml-preview gnus-buffer-configuration)) + (let ((gnus-message-buffer (current-buffer))) + (gnus-configure-windows 'mml-preview)) + (pop-to-buffer mml-preview-buffer))) (defun mml-validate () "Validate the current MML document." @@ -1171,4 +1522,5 @@ If RAW, don't highlight the article." (provide 'mml) +;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12 ;;; mml.el ends here