X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmml.el;h=db0c20e6517744e055b9486407ecd05280723f91;hb=50dffefb002f44bbc1d0c1785d652801cddc0326;hp=87826014c43fef1b9cdb2bfa479597067a3c4668;hpb=5a113e2f6ed127a7a9bb3a4d7e7003c869f419d2;p=gnus diff --git a/lisp/mml.el b/lisp/mml.el index 87826014c..db0c20e65 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -1,6 +1,7 @@ ;;; 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 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. @@ -17,8 +18,8 @@ ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -36,14 +37,28 @@ (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 'fill-flowed-encode "flow-fill") - (autoload 'message-posting-charset "message") - (autoload 'x-dnd-get-local-file-name "x-dnd")) + (autoload 'message-posting-charset "message")) + +(eval-when-compile + (autoload 'dnd-get-local-file-name "dnd")) + +(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) (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 +66,14 @@ 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 "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 +137,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 +154,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 +177,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))) @@ -177,6 +202,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") @@ -392,23 +421,31 @@ 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 + (setq charset (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,6 +463,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"))) @@ -442,6 +483,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")) @@ -463,11 +505,17 @@ 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 (with-current-buffer (cdr (assq 'buffer cont)) + (mm-with-unibyte-current-buffer + (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) @@ -505,15 +553,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") @@ -594,7 +648,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) @@ -700,7 +754,8 @@ 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)) @@ -801,7 +856,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (insert " " param) (when (> (current-column) 71) (goto-char point) - (insert "\n ") + (insert "\n") (end-of-line))))) ;;; @@ -815,6 +870,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) @@ -852,26 +912,54 @@ 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 MIME message"))] + ["Attach External..." mml-attach-external + ,@(if (featurep 'xemacs) '(t) + '(:help "Attach reference to file"))] + ;; + ("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"))] + ;; 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)] + ;; + ;; 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" 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])) @@ -890,11 +978,10 @@ See Info node `(emacs-mime)Composing'. (> (prefix-numeric-value arg) 0))) (add-minor-mode 'mml-mode " MML" mml-mode-map) (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)))) + (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))) ;;; @@ -937,15 +1024,15 @@ See Info node `(emacs-mime)Composing'. 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) + (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 - nil))) + nil t nil nil default))) (if (not (equal disposition "")) disposition default))) @@ -992,6 +1079,36 @@ 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 "23.0" ;; No Gnus + :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 "Non" nil) + (const :tag "Query" t) + (list :value (type description disposition) + (set :inline t + (const type) + (const description) + (const disposition)))) + :version "23.0" ;; No Gnus + :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 @@ -1006,19 +1123,36 @@ description of the attachment." (description (mml-minibuffer-read-description)) (disposition (mml-minibuffer-read-disposition type))) (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))) + (save-excursion + (unless (message-in-body-p) (goto-char (point-max))) + (mml-insert-empty-tag 'part + 'type type + 'filename 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* ((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))) (mml-attach-file file type description disposition))))) (defun mml-attach-buffer (buffer &optional type description) @@ -1029,8 +1163,11 @@ See `mml-attach-file' for details of operation." (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)) + (save-excursion + (unless (message-in-body-p) (goto-char (point-max))) + (mml-insert-empty-tag 'part 'type type 'buffer buffer + 'disposition "attachment" + 'description description))) (defun mml-attach-external (file &optional type description) "Attach an external file into the buffer. @@ -1041,8 +1178,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): " @@ -1070,10 +1209,20 @@ 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) + (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) @@ -1085,13 +1234,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 @@ -1104,6 +1253,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) @@ -1136,7 +1286,13 @@ If RAW, don't highlight the article." (lambda (event) (interactive "@e") (widget-button-press (widget-event-point event) event))) - (goto-char (point-min))))) + (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." @@ -1182,4 +1338,5 @@ If RAW, don't highlight the article." (provide 'mml) +;;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12 ;;; mml.el ends here