X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmml.el;h=1975af4183af637d8c82df19eeed6f1c2d5d3286;hb=b486163ca5124b37cc90c5fbca5d1f3f105c85f1;hp=5c87d9b7adb9665db96d355a607b866bbf81fdd7;hpb=cedbae0783d4904ca140b76f711675be4479be06;p=gnus diff --git a/lisp/mml.el b/lisp/mml.el index 5c87d9b7a..1975af418 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -1,49 +1,75 @@ ;;; 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, 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: ;;; Code: +;; For Emacs <22.2 and XEmacs. +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + (require 'mm-util) (require 'mm-bodies) (require 'mm-encode) (require 'mm-decode) (require 'mml-sec) (eval-when-compile (require 'cl)) - -(eval-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 'fill-flowed-encode "flow-fill") - (autoload 'message-posting-charset "message") - (autoload 'x-dnd-get-local-file-name "x-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") +(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 +77,62 @@ 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-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 "24.1" + :type 'boolean + :group 'message) + +(defcustom mml-enable-flowed t + "If non-nil, enable format=flowed usage when encoding a message. +This is only performed when filling on text/plain with hard +newlines in the text." + :version "24.1" :type 'boolean :group 'message) @@ -120,7 +196,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,7 +213,7 @@ 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 () @@ -154,6 +236,11 @@ one charsets.") ;; included in the message (let* (secure-mode (taginfo (mml-read-tag)) + (keyfile (cdr (assq 'keyfile 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))) @@ -177,6 +264,12 @@ one charsets.") (setq tags (list "sign" method "encrypt" method)))) (eval `(mml-insert-tag ,secure-mode ,@tags + ,(if keyfile "keyfile") + ,keyfile + ,@(apply #'append + (mapcar (lambda (certfile) + (list "certfile" certfile)) + certfiles)) ,(if recipients "recipients") ,recipients ,(if sender "sender") @@ -316,8 +409,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)) @@ -376,7 +469,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)) @@ -392,23 +485,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)))) @@ -426,8 +532,15 @@ 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)) + (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)))) @@ -441,7 +554,9 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." ;; in the mml tag or it says "flowed" and there ;; actually are hard newlines in the text. (let (use-hard-newlines) - (when (and (string= type "text/plain") + (when (and mml-enable-flowed + (string= type "text/plain") + (not (string= (cdr (assq 'sign cont)) "pgp")) (or (null (assq 'format cont)) (string= (cdr (assq 'format cont)) "flowed")) @@ -453,7 +568,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))) @@ -463,19 +584,34 @@ 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))))) - (setq encoding (mm-encode-buffer type) + (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))))) + (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 @@ -505,15 +641,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") @@ -534,7 +676,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))) @@ -549,7 +692,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. @@ -576,7 +720,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)) @@ -593,7 +737,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) @@ -603,6 +747,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 @@ -618,10 +786,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)) @@ -633,7 +801,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)) @@ -641,8 +811,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 "") @@ -669,9 +842,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) @@ -693,13 +866,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)) @@ -717,28 +895,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) - (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 @@ -750,7 +942,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 @@ -794,14 +986,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 @@ -814,6 +1012,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) @@ -851,59 +1054,128 @@ 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])) - -(defvar mml-mode nil - "Minor mode for editing MML.") + ["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"))])) -(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 'x-dnd-protocol-alist) - (set (make-local-variable 'x-dnd-protocol-alist) - '(("^file:///" . mml-x-dnd-attach-file) - ("^file://" . x-dnd-open-file) - ("^file:" . mml-x-dnd-attach-file)))) - (run-hooks 'mml-mode-hook))) + (when (boundp 'dnd-protocol-alist) + (set (make-local-variable 'dnd-protocol-alist) + (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) @@ -914,7 +1186,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) @@ -922,9 +1198,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))) @@ -935,16 +1212,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 - (format "Disposition: (default %s): " default) - '(("attachment") ("inline") ("")) - nil - nil))) +(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))) @@ -991,45 +1265,121 @@ 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-x-dnd-attach-file (uri action) - "Attach a drag and drop file." - (let ((file (x-dnd-get-local-file-name uri t))) + ;; 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 + ;; icicles redefines read-file-name and returns a + ;; string w/ text properties :-/ + 'filename (mm-substring-no-properties file) + 'disposition (or 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-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* ((type (mml-minibuffer-read-type file)) - (description (mml-minibuffer-read-description)) - (disposition (mml-minibuffer-read-disposition type))) + (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) +(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))) + ;; 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) + (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. @@ -1040,24 +1390,43 @@ 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)) + ;; 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) + (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. @@ -1069,10 +1438,32 @@ 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)))) + (require 'gnus-msg) ; for gnus-setup-posting-charset (save-excursion (let* ((buf (current-buffer)) (message-options message-options) @@ -1084,13 +1475,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 @@ -1103,6 +1494,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) @@ -1135,7 +1527,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."